packages feed

ghc-lib 0.20210501 → 0.20210601

raw patch · 210 files changed

+7506/−7213 lines, 210 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

Files

compiler/GHC.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-}@@ -296,8 +297,6 @@   * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt. -} -#include "GhclibHsVersions.h"- import GHC.Prelude hiding (init)  import GHC.Platform@@ -310,7 +309,6 @@ import GHC.Driver.Errors.Types import GHC.Driver.CmdLine import GHC.Driver.Session-import qualified GHC.Driver.Session as Session import GHC.Driver.Backend import GHC.Driver.Config import GHC.Driver.Main@@ -332,7 +330,6 @@ import qualified GHC.Parser as Parser import GHC.Parser.Lexer import GHC.Parser.Annotation-import GHC.Parser.Errors.Ppr import GHC.Parser.Utils  import GHC.Iface.Load        ( loadSysInterface )@@ -913,10 +910,8 @@   -- the REPL. See #12356.   if xopt LangExt.StaticPointers dflags0   then do liftIO $ printOrThrowDiagnostics logger dflags0 $ singleMessage-            $ mkPlainMsgEnvelope dflags0 interactiveSrcSpan-               $ GhcDriverMessage $ DriverUnknownMessage-               $ mkPlainDiagnostic Session.WarningWithoutFlag-               $ text "StaticPointers is not supported in GHCi interactive expressions."+            $ fmap GhcDriverMessage+            $ mkPlainMsgEnvelope dflags0 interactiveSrcSpan DriverStaticPointersNotSupported           return $ xopt_unset dflags0 LangExt.StaticPointers   else return dflags0 @@ -1588,42 +1583,43 @@ -- on whether the module is interpreted or not.  --- Extract the filename, stringbuffer content and dynflags associed to a module+-- Extract the filename, stringbuffer content and dynflags associed to a ModSummary+-- Given an initialised GHC session a ModSummary can be retrieved for+-- a module by using 'getModSummary' -- -- XXX: Explain pre-conditions-getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)-getModuleSourceAndFlags mod = do-  m <- getModSummary (moduleName mod)+getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)+getModuleSourceAndFlags m = do   case ml_hs_file $ ms_location m of-    Nothing -> do dflags <- getDynFlags-                  liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)+    Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))     Just sourceFile -> do-        source <- liftIO $ hGetStringBuffer sourceFile+        source <- hGetStringBuffer sourceFile         return (sourceFile, source, ms_hspp_opts m)   -- | Return module source as token stream, including comments. ----- The module must be in the module graph and its source must be available.+-- A 'Module' can be turned into a 'ModSummary' using 'getModSummary' if+-- your session is fully initialised. -- Throws a 'GHC.Driver.Env.SourceError' on parse error.-getTokenStream :: GhcMonad m => Module -> m [Located Token]+getTokenStream :: ModSummary -> IO [Located Token] getTokenStream mod = do   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1   case lexTokenStream (initParserOpts dflags) source startLoc of     POk _ ts    -> return ts-    PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst))+    PFailed pst -> throwErrors (GhcPsMessage <$> getErrorMessages pst)  -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with -- 'showRichTokenStream'.-getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]+getRichTokenStream :: ModSummary -> IO [(Located Token, String)] getRichTokenStream mod = do   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1   case lexTokenStream (initParserOpts dflags) source startLoc of     POk _ ts    -> return $ addSourceToTokens startLoc source ts-    PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst))+    PFailed pst -> throwErrors (GhcPsMessage <$> getErrorMessages pst)  -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the@@ -1803,12 +1799,11 @@       PFailed pst ->          let (warns,errs) = getMessages pst in-         (foldPsMessages (mkParserWarn dflags) warns-         , Left (foldPsMessages mkParserErr errs))+         (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs)       POk pst rdr_module ->          let (warns,_) = getMessages pst in-         (foldPsMessages (mkParserWarn dflags) warns, Right rdr_module)+         (GhcPsMessage <$> warns, Right rdr_module)  -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists)
compiler/GHC/Builtin/Utils.hs view
@@ -3,8 +3,8 @@  -} -{-# LANGUAGE CPP #-} + -- | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge. -- -- This module serves as the central gathering point for names which the@@ -45,8 +45,6 @@      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Builtin.Uniques@@ -76,6 +74,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn) import GHC.Hs.Doc import GHC.Unit.Module.ModIface (IfaceExport)
compiler/GHC/ByteCode/Asm.hs view
@@ -15,8 +15,6 @@         mkTupleInfoLit   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.ByteCode.Instr@@ -34,13 +32,15 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Panic.Plain  import GHC.Core.TyCon import GHC.Data.FastString import GHC.Data.SizedSeq  import GHC.StgToCmm.Layout     ( ArgRep(..) )+import GHC.Cmm.Expr+import GHC.Cmm.CallConv        ( tupleRegsCover ) import GHC.Platform import GHC.Platform.Profile @@ -202,7 +202,7 @@   (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm    -- precomputed size should be equal to final size-  ASSERT(n_insns == sizeSS final_insns) return ()+  massert (n_insns == sizeSS final_insns)    let asm_insns = ssElts final_insns       insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns@@ -399,7 +399,7 @@                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)                                  info <- int (fromIntegral $-                                              mkTupleInfoSig tuple_info)+                                              mkTupleInfoSig platform tuple_info)                                  emit bci_PUSH_ALTS_T                                       [Op p, Op info, Op p_tup]   PUSH_PAD8                -> emit bci_PUSH_PAD8 []@@ -558,69 +558,35 @@ maxTupleNativeStackSize = 62  {--  Maximum number of supported registers for returning tuples.--  If GHC uses more more than these (because of a change in the calling-  convention or a new platform) mkTupleInfoSig will panic.--  You can raise the limits after modifying stg_ctoi_t and stg_ret_t-  (StgMiscClosures.cmm) to save and restore the additional registers.- -}-maxTupleVanillaRegs, maxTupleFloatRegs, maxTupleDoubleRegs,-    maxTupleLongRegs :: Int-maxTupleVanillaRegs = 6-maxTupleFloatRegs = 6-maxTupleDoubleRegs = 6-maxTupleLongRegs = 1--{-   Construct the tuple_info word that stg_ctoi_t and stg_ret_t use   to convert a tuple between the native calling convention and the   interpreter.    See Note [GHCi tuple layout] for more information.  -}-mkTupleInfoSig :: TupleInfo -> Word32-mkTupleInfoSig ti@TupleInfo{..}-  | tupleNativeStackSize > maxTupleNativeStackSize =-    pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler"+mkTupleInfoSig :: Platform -> TupleInfo -> Word32+mkTupleInfoSig platform TupleInfo{..}+  | tupleNativeStackSize > maxTupleNativeStackSize+  = pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler"              (ppr tupleNativeStackSize <+> text "stack words." <+>               text "Use -fobject-code to get around this limit"              )-  | tupleVanillaRegs `shiftR` maxTupleVanillaRegs /= 0 =-    pprPanic "mkTupleInfoSig: too many vanilla registers" (ppr tupleVanillaRegs)-  | tupleLongRegs `shiftR` maxTupleLongRegs /= 0 =-    pprPanic "mkTupleInfoSig: too many long registers" (ppr tupleLongRegs)-  | tupleFloatRegs `shiftR` maxTupleFloatRegs /= 0 =-    pprPanic "mkTupleInfoSig: too many float registers" (ppr tupleFloatRegs)-  | tupleDoubleRegs `shiftR` maxTupleDoubleRegs /= 0 =-    pprPanic "mkTupleInfoSig: too many double registers" (ppr tupleDoubleRegs)-  {--    Check that we can pack the register counts/bitmaps and stack size-    in the information word. In particular we check that each component-    fits in the bits we have reserved for it.--    This overlaps with some of the above checks. It's likely that if the-    number of registers changes, the number of bits will also need to be-    updated.-   -}-  | tupleNativeStackSize < 16384 && -- 14 bits stack usage-    tupleDoubleRegs < 64 && -- 6 bit bitmap (these can be shared with float)-    tupleFloatRegs < 64 && -- 6 bit bitmap (these can be shared with double)-    tupleLongRegs < 4 && -- 2 bit bitmap-    tupleVanillaRegs < 65536 && -- 4 bit count (tupleVanillaRegs is still a bitmap)-    -- check that there are no "holes", i.e. that R1..Rn are all in use-    tupleVanillaRegs .&. (tupleVanillaRegs + 1) == 0-    = fromIntegral tupleNativeStackSize .|.-      unRegBitmap (tupleLongRegs `shiftL` 14) .|.-      unRegBitmap (tupleDoubleRegs `shiftL` 16) .|.-      unRegBitmap (tupleFloatRegs `shiftL` 22) .|.-      fromIntegral (countTrailingZeros (1 + tupleVanillaRegs) `shiftL` 28)-  | otherwise = pprPanic "mkTupleInfoSig: unsupported tuple shape" (ppr ti)+  | otherwise+  = assert (length regs <= 24) {- 24 bits for bitmap -}+    assert (tupleNativeStackSize < 255) {- 8 bits for stack size -}+    assert (all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}+    foldl' reg_bit 0 (zip regs [0..]) .|.+      (fromIntegral tupleNativeStackSize `shiftL` 24)+  where+    reg_bit :: Word32 -> (GlobalReg, Int) -> Word32+    reg_bit x (r, n)+      | r `elemRegSet` tupleRegs = x .|. 1 `shiftL` n+      | otherwise                = x+    regs = tupleRegsCover platform  mkTupleInfoLit :: Platform -> TupleInfo -> Literal mkTupleInfoLit platform tuple_info =-  mkLitWord platform . fromIntegral $ mkTupleInfoSig tuple_info+  mkLitWord platform . fromIntegral $ mkTupleInfoSig platform tuple_info  -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the
compiler/GHC/ByteCode/InfoTable.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --@@ -7,8 +7,6 @@  -- | Generate infotables for interpreter-made bytecodes module GHC.ByteCode.InfoTable ( mkITbls ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/ByteCode/Instr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -funbox-strict-fields #-} --@@ -9,8 +9,6 @@ module GHC.ByteCode.Instr (         BCInstr(..), ProtoBCO(..), bciStackUse, LocalLabel(..)   ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/ByteCode/Linker.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                   #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MagicHash             #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -20,8 +19,6 @@   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Runtime.Interpreter@@ -39,8 +36,8 @@ import GHC.Data.SizedSeq  import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable-import GHC.Utils.Misc  import GHC.Types.Name import GHC.Types.Name.Env@@ -150,7 +147,7 @@     -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))      | otherwise-    -> ASSERT2(isExternalName nm, ppr nm)+    -> assertPpr (isExternalName nm) (ppr nm) $        do           let sym_to_find = nameToCLabel nm "closure"           m <- lookupSymbol interp sym_to_find@@ -187,7 +184,7 @@ nameToCLabel n suffix = mkFastString label   where     encodeZ = zString . zEncodeFS-    (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n+    (Module pkgKey modName) = assert (isExternalName n) $ nameModule n     packagePart = encodeZ (unitFS pkgKey)     modulePart  = encodeZ (moduleNameFS modName)     occPart     = encodeZ (occNameFS (nameOccName n))
compiler/GHC/Cmm/CallConv.hs view
@@ -2,10 +2,12 @@   ParamLocation(..),   assignArgumentsPos,   assignStack,-  realArgRegsCover+  realArgRegsCover,+  tupleRegsCover ) where  import GHC.Prelude+import Data.List (nub)  import GHC.Cmm.Expr import GHC.Runtime.Heap.Layout@@ -219,3 +221,13 @@       realDoubleRegs platform ++       realLongRegs   platform       -- we don't save XMM registers if they are not used for parameter passing++-- Like realArgRegsCover but always includes the node. This covers the real+-- and virtual registers used for unboxed tuples.+--+-- Note: if anything changes in how registers for unboxed tuples overlap,+--       make sure to also update GHC.StgToByteCode.layoutTuple.++tupleRegsCover :: Platform -> [GlobalReg]+tupleRegsCover platform =+  nub (VanillaReg 1 VGcPtr : realArgRegsCover platform)
compiler/GHC/Cmm/Graph.hs view
@@ -38,8 +38,8 @@ import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff) import GHC.Types.Unique.Supply-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)   -----------------------------------------------------------------------------
compiler/GHC/Cmm/Info.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ module GHC.Cmm.Info (   mkEmptyContInfoTable,   cmmToRawCmm,@@ -32,8 +32,6 @@   stdPtrsOffset, stdNonPtrsOffset, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Cmm@@ -51,6 +49,7 @@ import GHC.Driver.Session import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.Unique.Supply import GHC.Utils.Logger import GHC.Utils.Monad@@ -257,7 +256,7 @@         slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)         srt_lit = case srt_label of                     []          -> mkIntCLit platform 0-                    (lit:_rest) -> ASSERT( null _rest ) lit+                    (lit:_rest) -> assert (null _rest) lit      mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
compiler/GHC/Cmm/LayoutStack.hs view
@@ -12,14 +12,11 @@ import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs  ) -- XXX layering violation import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation -import GHC.Types.Basic import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.BlockId-import GHC.Cmm.CLabel import GHC.Cmm.Utils import GHC.Cmm.Graph-import GHC.Types.ForeignCall import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint import GHC.Runtime.Heap.Layout@@ -34,7 +31,6 @@ import GHC.Utils.Misc  import GHC.Driver.Session-import GHC.Data.FastString import GHC.Utils.Outputable hiding ( isEmpty ) import GHC.Utils.Panic import qualified Data.Set as Set@@ -1190,21 +1186,14 @@   | otherwise = return block  -foreignLbl :: FastString -> CmmExpr-foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))- callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O callSuspendThread platform id intrbl =-  CmmUnsafeForeignCall-       (ForeignTarget (foreignLbl (fsLit "suspendThread"))-        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))+  CmmUnsafeForeignCall (PrimTarget MO_SuspendThread)        [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]  callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id =-  CmmUnsafeForeignCall-       (ForeignTarget (foreignLbl (fsLit "resumeThread"))-            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))+  CmmUnsafeForeignCall (PrimTarget MO_ResumeThread)        [new_base] [CmmReg (CmmLocal id)]  -- -----------------------------------------------------------------------------
compiler/GHC/Cmm/Lexer.x view
@@ -26,7 +26,9 @@ import GHC.Data.StringBuffer import GHC.Data.FastString import GHC.Parser.CharClass-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()+import GHC.Utils.Error import GHC.Utils.Misc --import TRACE @@ -326,7 +328,9 @@     AlexEOF -> do let span = mkPsSpan loc1 loc1                   liftP (setLastToken span 0)                   return (L span CmmT_EOF)-    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (PsError PsErrCmmLexer [])+    AlexError (loc2,_) ->+      let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer+      in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg     AlexSkip inp2 _ -> do         setInput inp2         lexToken
compiler/GHC/Cmm/Parser.y view
@@ -239,7 +239,8 @@ import GHC.Cmm.CallConv import GHC.Runtime.Heap.Layout import GHC.Parser.Lexer-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr  import GHC.Types.CostCentre import GHC.Types.ForeignCall@@ -270,8 +271,6 @@ import Data.Maybe import qualified Data.Map as M import qualified Data.ByteString.Char8 as BS8--#include "GhclibHsVersions.h" }  %expect 0@@ -920,7 +919,7 @@ nameToMachOp :: FastString -> PD (Width -> MachOp) nameToMachOp name =   case lookupUFM machOps name of-        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []+        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)         Just m  -> return m  exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)@@ -1029,6 +1028,9 @@         ( "memmove", memcpyLikeTweakArgs MO_Memmove ),         ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ), +        ( "suspendThread", (MO_SuspendThread,) ),+        ( "resumeThread",  (MO_ResumeThread,) ),+         ("prefetch0", (MO_Prefetch_Data 0,)),         ("prefetch1", (MO_Prefetch_Data 1,)),         ("prefetch2", (MO_Prefetch_Data 2,)),@@ -1082,12 +1084,14 @@ parseSafety "safe"   = return PlaySafe parseSafety "unsafe" = return PlayRisky parseSafety "interruptible" = return PlayInterruptible-parseSafety str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedSafety str)) []+parseSafety str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $+                                              PsErrCmmParser (CmmUnrecognisedSafety str)  parseCmmHint :: String -> PD ForeignHint parseCmmHint "ptr"    = return AddrHint parseCmmHint "signed" = return SignedHint-parseCmmHint str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedHint str)) []+parseCmmHint str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $+                                               PsErrCmmParser (CmmUnrecognisedHint str)  -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint@@ -1114,7 +1118,7 @@ stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) stmtMacro fun args_code = do   case lookupUFM stmtMacros fun of-    Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownMacro fun)) []+    Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun)     Just fcode -> return $ do         args <- sequence args_code         code (fcode args)@@ -1147,6 +1151,9 @@   ( fsLit "SAVE_REGS",             \[] -> emitSaveRegs ),   ( fsLit "RESTORE_REGS",          \[] -> emitRestoreRegs ), +  ( fsLit "PUSH_TUPLE_REGS",      \[live_regs] -> emitPushTupleRegs live_regs ),+  ( fsLit "POP_TUPLE_REGS",       \[live_regs] -> emitPopTupleRegs live_regs ),+   ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),   ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ), @@ -1217,7 +1224,8 @@   = do  conv <- case conv_string of           "C"       -> return CCallConv           "stdcall" -> return StdCallConv-          _         -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownCConv conv_string)) []+          _         -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $+                                              PsErrCmmParser (CmmUnknownCConv conv_string)         return $ do           platform <- getPlatform           results <- sequence results_code@@ -1295,7 +1303,7 @@   = do     platform <- PD.getPlatform     case lookupUFM (callishMachOps platform) name of-        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []+        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)         Just f  -> return $ do                 results <- sequence results_code                 args <- sequence args_code@@ -1450,7 +1458,11 @@   where platform = profilePlatform profile  -parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt]))+parseCmmFile :: DynFlags+             -> Module+             -> HomeUnit+             -> FilePath+             -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt])) parseCmmFile dflags this_mod home_unit filename = do   buf <- hGetStringBuffer filename   let@@ -1473,7 +1485,7 @@               return (cmm ++ cmm2, used_info)             (cmm, _) = runC dflags no_module st fcode             (warnings,errors) = getMessages pst-        if not (isEmptyBag errors)+        if not (isEmptyMessages errors)          then return (warnings, errors, Nothing)          else return (warnings, errors, Just cmm)   where
compiler/GHC/Cmm/Parser/Monad.hs view
@@ -27,7 +27,8 @@  import GHC.Driver.Session import GHC.Parser.Lexer-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Types.Error ( MsgEnvelope ) import GHC.Types.SrcLoc import GHC.Unit.Types import GHC.Unit.Home@@ -47,7 +48,7 @@ liftP :: P a -> PD a liftP (P f) = PD $ \_ _ s -> f s -failMsgPD :: (SrcSpan -> PsError) -> PD a+failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a failMsgPD = liftP . failMsgP  returnPD :: a -> PD a
compiler/GHC/Cmm/Ppr.hs view
@@ -56,7 +56,7 @@ import GHC.Utils.Outputable import GHC.Cmm.Ppr.Decl import GHC.Cmm.Ppr.Expr-import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn)  import GHC.Types.Basic import GHC.Cmm.Dataflow.Block
compiler/GHC/Cmm/Sink.hs view
@@ -622,10 +622,16 @@   -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]   | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True -  -- (6) native calls clobber any memory+  -- (6) suspendThread clobbers every global register not backed by a real+  -- register. It also clobbers heap and stack but this is handled by (5)+  | CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) _ _ <- node+  , foldRegsUsed platform (\b g -> globalRegMaybe platform g == Nothing || b) False rhs+  = True++  -- (7) native calls clobber any memory   | CmmCall{} <- node, memConflicts addr AnyMem                   = True -  -- (7) otherwise, no conflict+  -- (8) otherwise, no conflict   | otherwise = False  {- Note [Inlining foldRegsDefd]@@ -759,6 +765,10 @@ -- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and -- therefore we should never float any memory operations across one of -- these calls.+--+-- `suspendThread` releases the capability used by the thread, hence we mustn't+-- float accesses to heap, stack or virtual global registers stored in the+-- capability (e.g. with unregisterised build, see #19237).   bothMems :: AbsMem -> AbsMem -> AbsMem
compiler/GHC/CmmToAsm.hs view
@@ -6,7 +6,6 @@ -- -----------------------------------------------------------------------------  {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -80,8 +79,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import qualified GHC.CmmToAsm.X86   as X86@@ -134,9 +131,12 @@ import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Exception (evaluate)+import GHC.Utils.Constants (debugIsOn)+ import GHC.Data.FastString import GHC.Types.Unique.Set-import GHC.Utils.Error import GHC.Unit import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream@@ -144,7 +144,6 @@ import Data.List (sortBy, groupBy) import Data.Maybe import Data.Ord         ( comparing )-import Control.Exception import Control.Monad import System.IO @@ -724,8 +723,7 @@ checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]             -> [NatCmmDecl statics instr] checkLayout procsUnsequenced procsSequenced =-        ASSERT2(setNull diff,-                ppr "Block sequencing dropped blocks:" <> ppr diff)+        assertPpr (setNull diff) (ppr "Block sequencing dropped blocks:" <> ppr diff)         procsSequenced   where         blocks1 = foldl' (setUnion) setEmpty $
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -13,7 +13,6 @@     ( sequenceTop, backendMaintainsCfg) where -#include "GhclibHsVersions.h" import GHC.Prelude  import GHC.Driver.Ppr     (pprTrace)@@ -31,11 +30,12 @@  import GHC.Platform import GHC.Types.Unique.FM-import GHC.Utils.Misc  import GHC.Data.Graph.Directed import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc import GHC.Data.Maybe  -- DEBUGGING ONLY@@ -312,7 +312,7 @@ -- in the chain. instance Ord (BlockChain) where    (BlockChain lbls1) `compare` (BlockChain lbls2)-       = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2)+       = assert (toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2) $          strictlyOrdOL lbls1 lbls2  instance Outputable (BlockChain) where@@ -719,7 +719,7 @@             directEdges          (neighbourChains, combined)-            = ASSERT(noDups $ mapElems builtChains)+            = assert (noDups $ mapElems builtChains) $               {-# SCC "groupNeighbourChains" #-}             --   pprTraceIt "NeighbourChains" $               combineNeighbourhood rankedEdges (mapElems builtChains)@@ -759,7 +759,7 @@ #endif          blockList-            = ASSERT(noDups [masterChain])+            = assert (noDups [masterChain])               (concatMap fromOL $ map chainBlocks prepedChains)          --chainPlaced = setFromList $ map blockId blockList :: LabelSet@@ -773,14 +773,14 @@             -- We want debug builds to catch this as it's a good indicator for             -- issues with CFG invariants. But we don't want to blow up production             -- builds if something slips through.-            ASSERT(null unplaced)+            assert (null unplaced) $             --pprTraceIt "placedBlocks" $             -- ++ [] is stil kinda expensive             if null unplaced then blockList else blockList ++ unplaced         getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap     in         --Assert we placed all blocks given as input-        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)+        assert (all (\bid -> mapMember bid blockMap) placedBlocks) $         dropJumps info $ map getBlock placedBlocks  {-# SCC dropJumps #-}
compiler/GHC/CmmToAsm/CFG.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                        #-} {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types                 #-}@@ -40,8 +39,6 @@      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -74,6 +71,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList@@ -212,7 +210,7 @@ hasNode :: CFG -> BlockId -> Bool hasNode m node =   -- Check the invariant that each node must exist in the first map or not at all.-  ASSERT( found || not (any (mapMember node) m))+  assert (found || not (any (mapMember node) m))   found     where       found = mapMember node m@@ -645,8 +643,8 @@         (CmmCall { cml_cont = Nothing })   -> []         other ->             panic "Foo" $-            ASSERT2(False, ppr "Unknown successor cause:" <>-              (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other)))+            assertPpr False (ppr "Unknown successor cause:" <>+              (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other))) $             map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other       where         bid = G.entryLabel block
compiler/GHC/CmmToAsm/Monad.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} @@ -42,8 +41,6 @@ )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}  -----------------------------------------------------------------------------@@ -21,8 +20,6 @@  where -#include "GhclibHsVersions.h"- -- NCG stuff: import GHC.Prelude @@ -64,13 +61,13 @@ import GHC.Data.OrdList import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad    ( mapAndUnzipM, when ) import Data.Word  import GHC.Types.Basic import GHC.Data.FastString-import GHC.Utils.Misc  -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector@@ -468,7 +465,7 @@ getRegister' _ platform (CmmLoad mem pk)  | not (isWord64 pk) = do         Amode addr addr_code <- getAmode D mem-        let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)+        let code dst = assert ((targetClassOfReg platform dst == RcDouble) == isFloatType pk) $                        addr_code `snocOL` LD format dst addr         return (Any format code)  | not (target32Bit platform) = do@@ -981,7 +978,8 @@   | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y   = do       let op_len = max W32 width-      let extend = extendSExpr width op_len+      let extend = if condUnsigned cond then extendUExpr width op_len+                   else extendSExpr width op_len       (src1, code) <- getSomeReg (extend x)       let format = intFormat op_len           code' = code `snocOL`@@ -2014,6 +2012,9 @@                     MO_Memset _  -> (fsLit "memset", False)                     MO_Memmove _ -> (fsLit "memmove", False)                     MO_Memcmp _  -> (fsLit "memcmp", False)++                    MO_SuspendThread -> (fsLit "suspendThread", False)+                    MO_ResumeThread  -> (fsLit "resumeThread", False)                      MO_BSwap w   -> (bSwapLabel w, False)                     MO_BRev w    -> (bRevLabel w, False)
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -----------------------------------------------------------------------------@@ -9,8 +7,6 @@ -- (c) The University of Glasgow 1993-2004 -- -------------------------------------------------------------------------------#include "GhclibHsVersions.h"  module GHC.CmmToAsm.PPC.Instr    ( Instr(..)
compiler/GHC/CmmToAsm/PPC/RegInfo.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- --@@ -16,8 +15,6 @@ )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/PPC/Regs.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1994-2004@@ -47,8 +45,6 @@ )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/Ppr.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}  ----------------------------------------------------------------------------- --
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-}+{-# LANGUAGE BangPatterns, DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -1,12 +1,8 @@-{-# LANGUAGE CPP #-}- module GHC.CmmToAsm.Reg.Graph.TrivColorable (         trivColorable, )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -101,9 +101,6 @@         module  GHC.CmmToAsm.Reg.Linear.Base,         module  GHC.CmmToAsm.Reg.Linear.Stats   ) where--#include "GhclibHsVersions.h"-  import GHC.Prelude
compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view
@@ -1,12 +1,7 @@-{-# LANGUAGE CPP #-}- module GHC.CmmToAsm.Reg.Linear.FreeRegs (     FR(..),     maxSpillSlots )--#include "GhclibHsVersions.h"- where  import GHC.Prelude
compiler/GHC/CmmToAsm/Reg/Linear/State.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-}+{-# LANGUAGE PatternSynonyms, DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-}
compiler/GHC/CmmToAsm/Reg/Target.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ -- | Hard wired things related to registers. --      This is module is preventing the native code generator being able to --      emit code for non-host architectures.@@ -18,8 +18,6 @@ )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Generating machine code (instruction selection)@@ -17,8 +17,6 @@  where -#include "GhclibHsVersions.h"- -- NCG stuff: import GHC.Prelude @@ -666,6 +664,9 @@         MO_Memset _  -> fsLit "memset"         MO_Memmove _ -> fsLit "memmove"         MO_Memcmp _  -> fsLit "memcmp"++        MO_SuspendThread -> fsLit "suspendThread"+        MO_ResumeThread  -> fsLit "resumeThread"          MO_BSwap w          -> bSwapLabel w         MO_BRev w           -> bRevLabel w
compiler/GHC/CmmToAsm/SPARC/Instr.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Machine-dependent assembly language@@ -7,8 +7,6 @@ -- (c) The University of Glasgow 1993-2004 -- ------------------------------------------------------------------------------#include "GhclibHsVersions.h"- module GHC.CmmToAsm.SPARC.Instr    ( Instr(..)    , RI(..)
compiler/GHC/CmmToAsm/SPARC/Ppr.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}@@ -24,8 +23,6 @@ )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE TupleSections #-}@@ -28,8 +27,6 @@  where -#include "GhclibHsVersions.h"- -- NCG stuff: import GHC.Prelude @@ -79,7 +76,9 @@ import GHC.Types.ForeignCall ( CCallConv(..) ) import GHC.Data.OrdList import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Driver.Session import GHC.Utils.Misc@@ -1268,7 +1267,7 @@       -- what mangleIndexTree has just done.       CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]          | is32BitLit is32Bit lit-         -- ASSERT(rep == II32)???+         -- assert (rep == II32)???          -> do             (x_reg, x_code) <- getSomeReg x             let off = ImmInt (-(fromInteger i))@@ -1276,7 +1275,7 @@        CmmMachOp (MO_Add _rep) [x, CmmLit lit]          | is32BitLit is32Bit lit-         -- ASSERT(rep == II32)???+         -- assert (rep == II32)???          -> do             (x_reg, x_code) <- getSomeReg x             let off = litToImm lit@@ -1474,7 +1473,7 @@   where     check :: Format -> Reg -> InstrBlock     check fmt reg =-        ASSERT(not $ isFloatFormat fmt)+        assert (not $ isFloatFormat fmt) $         toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)              , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel              ]@@ -1941,10 +1940,10 @@                   -- Use ASSERT so we don't break releases if                   -- LTT/LE creep in somehow.                   LTT ->-                    ASSERT2(False, ppr "Should have been turned into >")+                    assertPpr False (ppr "Should have been turned into >")                     and_ordered                   LE  ->-                    ASSERT2(False, ppr "Should have been turned into >=")+                    assertPpr False (ppr "Should have been turned into >=")                     and_ordered                   _   -> and_ordered @@ -2885,7 +2884,7 @@         lreg <- newLocalReg $ cmmExprType platform actual         (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual         -- The above assignment shouldn't change the current block-        MASSERT(isNothing bid1)+        massert (isNothing bid1)         return (instrs, CmmReg $ CmmLocal lreg)      newLocalReg :: CmmType -> NatM LocalReg@@ -2961,7 +2960,7 @@                 -- Arguments can be smaller than 32-bit, but we still use @PUSH                 -- II32@ - the usual calling conventions expect integers to be                 -- 4-byte aligned.-                ASSERT((typeWidth arg_ty) <= W32) return ()+                massert ((typeWidth arg_ty) <= W32)                 (operand, code) <- getOperand arg                 delta <- getDeltaNat                 setDeltaNat (delta-size)@@ -2988,7 +2987,7 @@          push_codes <- mapM push_arg (reverse prom_args)         delta <- getDeltaNat-        MASSERT(delta == delta0 - tot_arg_size)+        massert (delta == delta0 - tot_arg_size)          -- deal with static vs dynamic call targets         (callinsns,cconv) <-@@ -2999,8 +2998,8 @@                where fn_imm = ImmCLbl lbl             ForeignTarget expr conv                -> do { (dyn_r, dyn_c) <- getSomeReg expr-                     ; ASSERT( isWord32 (cmmExprType platform expr) )-                       return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }+                     ; massert (isWord32 (cmmExprType platform expr))+                     ; return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }             PrimTarget _                 -> panic $ "genCCall: Can't handle PrimTarget call type here, error "                             ++ "probably because too many return values."@@ -3186,7 +3185,7 @@              -- Arguments can be smaller than 64-bit, but we still use @PUSH              -- II64@ - the usual calling conventions expect integers to be              -- 8-byte aligned.-             ASSERT(width <= W64) return ()+             massert (width <= W64)              (arg_op, arg_code) <- getOperand arg              delta <- getDeltaNat              setDeltaNat (delta-arg_size)@@ -3396,6 +3395,9 @@               MO_Memmove _ -> fsLit "memmove"               MO_Memcmp _  -> fsLit "memcmp" +              MO_SuspendThread -> fsLit "suspendThread"+              MO_ResumeThread  -> fsLit "resumeThread"+               MO_PopCnt _  -> fsLit "popcnt"               MO_BSwap _   -> fsLit "bswap"               {- Here the C implementation is used as there is no x86@@ -3620,9 +3622,9 @@                 GU  -> plain_test   dst                 GEU -> plain_test   dst                 -- Use ASSERT so we don't break releases if these creep in.-                LTT -> ASSERT2(False, ppr "Should have been turned into >")+                LTT -> assertPpr False (ppr "Should have been turned into >") $                        and_ordered  dst-                LE  -> ASSERT2(False, ppr "Should have been turned into >=")+                LE  -> assertPpr False (ppr "Should have been turned into >=") $                        and_ordered  dst                 _   -> and_ordered  dst)
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-}  ----------------------------------------------------------------------------- --@@ -36,8 +36,6 @@    , isJumpishInstr    ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-}  -----------------------------------------------------------------------------@@ -19,8 +19,6 @@ )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/X86/RegInfo.hs view
@@ -1,12 +1,10 @@-{-# LANGUAGE CPP #-}+ module GHC.CmmToAsm.X86.RegInfo (         mkVirtualReg,         regDotColor )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/X86/Regs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.CmmToAsm.X86.Regs (         -- squeese functions for the graph allocator         virtualRegSqueeze,@@ -46,8 +46,6 @@ )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToC.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP           #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs         #-} {-# LANGUAGE LambdaCase    #-}@@ -26,8 +25,6 @@    ) where -#include "GhclibHsVersions.h"- -- Cmm stuff import GHC.Prelude @@ -271,12 +268,18 @@         hresults = zip results res_hints         hargs    = zip args arg_hints +        need_cdecl+          | Just _align <- machOpMemcpyishAlign op = True+          | MO_ResumeThread  <- op                 = True+          | MO_SuspendThread <- op                 = True+          | otherwise                              = False+         fn_call           -- The mem primops carry an extra alignment arg.           -- We could maybe emit an alignment directive using this info.           -- We also need to cast mem primops to prevent conflicts with GCC           -- builtins (see bug #5967).-          | Just _align <- machOpMemcpyishAlign op+          | need_cdecl           = (text ";EFF_(" <> fn <> char ')' <> semi) $$             pprForeignCall platform fn cconv hresults hargs           | otherwise@@ -828,6 +831,9 @@         MO_Memmove _    -> text "memmove"         MO_Memcmp _     -> text "memcmp" +        MO_SuspendThread -> text "suspendThread"+        MO_ResumeThread  -> text "resumeThread"+         MO_BSwap w          -> ftext (bSwapLabel w)         MO_BRev w           -> ftext (bRevLabel w)         MO_PopCnt w         -> ftext (popCntLabel w)@@ -973,7 +979,7 @@  pprAsPtrReg :: CmmReg -> SDoc pprAsPtrReg (CmmGlobal (VanillaReg n gcp))-  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"+  = warnPprTrace (gcp /= VGcPtr) (ppr n) $ char 'R' <> int n <> text ".p" pprAsPtrReg other_reg = pprReg other_reg  pprGlobalReg :: GlobalReg -> SDoc
compiler/GHC/CmmToLlvm.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-}+{-# LANGUAGE TypeFamilies, ViewPatterns, OverloadedStrings #-}  -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator.@@ -10,8 +10,6 @@    , llvmFixupAsm    ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToLlvm/Base.hs view
@@ -39,7 +39,6 @@         aliasify, llvmDefLabel     ) where -#include "GhclibHsVersions.h" #include "ghcautoconf.h"  import GHC.Prelude
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -1,24 +1,24 @@-{-# LANGUAGE CPP, GADTs, MultiWayIf #-}+{-# 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 -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Platform+import GHC.Platform.Regs ( activeStgRegs )+ import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Regs  import GHC.Cmm.BlockId-import GHC.Platform.Regs ( activeStgRegs ) import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Ppr as PprCmm@@ -29,14 +29,15 @@ import GHC.Cmm.Dataflow.Collections  import GHC.Data.FastString-import GHC.Types.ForeignCall-import GHC.Utils.Outputable-import GHC.Utils.Panic (assertPanic)-import qualified GHC.Utils.Panic as Panic-import GHC.Platform import GHC.Data.OrdList++import GHC.Types.ForeignCall import GHC.Types.Unique.Supply import GHC.Types.Unique++import GHC.Utils.Outputable+import GHC.Utils.Panic.Plain (massert)+import qualified GHC.Utils.Panic as Panic import GHC.Utils.Misc  import Control.Monad.Trans.Class@@ -559,7 +560,7 @@                             , MO_AddWordC w                             , MO_SubWordC w                             ]-    MASSERT(valid)+    massert valid     let width = widthToLlvmInt w     -- This will do most of the work of generating the call to the intrinsic and     -- extracting the values from the struct.@@ -860,6 +861,9 @@     MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1     MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2     MO_Memcmp _   -> fsLit $ "memcmp"++    MO_SuspendThread -> fsLit $ "suspendThread"+    MO_ResumeThread  -> fsLit $ "resumeThread"      (MO_PopCnt w) -> fsLit $ "llvm.ctpop."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)     (MO_BSwap w)  -> fsLit $ "llvm.bswap."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)
compiler/GHC/CmmToLlvm/Data.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ -- ---------------------------------------------------------------------------- -- | Handle conversion of CmmData to LLVM code. --@@ -6,8 +6,6 @@ module GHC.CmmToLlvm.Data (         genLlvmData, genData     ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToLlvm/Mangler.hs view
@@ -18,8 +18,8 @@ import GHC.Utils.Error ( withTiming ) import GHC.Utils.Outputable ( text ) import GHC.Utils.Logger+import GHC.Utils.Exception (try) -import Control.Exception import qualified Data.ByteString.Char8 as B import System.IO
compiler/GHC/CmmToLlvm/Ppr.hs view
@@ -1,13 +1,11 @@-{-# LANGUAGE CPP #-} + -- ---------------------------------------------------------------------------- -- | Pretty print helpers for the LLVM Code generator. -- module GHC.CmmToLlvm.Ppr (         pprLlvmCmmDecl, pprLlvmData, infoSection     ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToLlvm/Regs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -------------------------------------------------------------------------------- -- | Deal with Cmm registers --@@ -8,8 +8,6 @@         lmGlobalRegArg, lmGlobalRegVar, alwaysLive,         stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA     ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Core/Map/Expr.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-}@@ -23,8 +22,6 @@    lkDNamed, xtDNamed,    (>.>), (|>), (|>>),  ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Core/Opt/CSE.hs view
@@ -4,15 +4,13 @@ \section{Common subexpression} -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}  module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core.Subst@@ -32,7 +30,7 @@ import GHC.Types.Basic import GHC.Types.Tickish import GHC.Core.Map.Expr-import GHC.Utils.Misc   ( filterOut, equalLength, debugIsOn )+import GHC.Utils.Misc   ( filterOut, equalLength ) import GHC.Utils.Panic import Data.List        ( mapAccumL ) @@ -693,7 +691,7 @@   , Alt _ bndrs1 rhs1 <- alt1   , let filtered_alts = filterOut (identical_alt rhs1) rest_alts   , not (equalLength rest_alts filtered_alts)-  = ASSERT2( null bndrs1, ppr alts )+  = assertPpr (null bndrs1) (ppr alts) $     Alt DEFAULT [] rhs1 : filtered_alts    | otherwise
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate@@ -9,8 +8,6 @@ -- See Note [Phase ordering]. module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -19,6 +16,7 @@ import GHC.Core import GHC.Core.Seq import GHC.Utils.Outputable+import GHC.Builtin.Names ( runRWKey ) import GHC.Types.Var.Env import GHC.Types.Basic import GHC.Types.Id@@ -31,7 +29,7 @@ import GHC.Core.Type import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe ) import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger  ( Logger, dumpIfSet_dyn, DumpFormat (..) ) import GHC.Data.Graph.UnVar -- for UnVarSet import GHC.Data.Maybe   ( isJust )@@ -151,8 +149,6 @@ cprAnal' _ (Type ty)     = (topCprType, Type ty)      -- Doesn't happen, in fact cprAnal' _ (Coercion co) = (topCprType, Coercion co) -cprAnal' env (Var var)   = (cprTransform env var, Var var)- cprAnal' env (Cast e co)   = (cpr_ty, Cast e' co)   where@@ -163,19 +159,10 @@   where     (cpr_ty, e') = cprAnal env e -cprAnal' env (App fun (Type ty))-  = (fun_ty, App fun' (Type ty))-  where-    (fun_ty, fun') = cprAnal env fun--cprAnal' env (App fun arg)-  = (res_ty, App fun' arg')-  where-    (fun_ty, fun') = cprAnal env fun-    -- In contrast to DmdAnal, there is no useful (non-nested) CPR info to be-    -- had by looking into the CprType of arg.-    (_, arg')      = cprAnal env arg-    res_ty         = applyCprTy fun_ty+cprAnal' env e@(Var{})+  = cprAnalApp env e [] []+cprAnal' env e@(App{})+  = cprAnalApp env e [] []  cprAnal' env (Lam var body)   | isTyVar var@@ -221,7 +208,7 @@       | DataAlt dc <- con       , let ids = filter isId bndrs       , CprType arity cpr <- scrut_ty-      , ASSERT( arity == 0 ) True+      , assert (arity == 0 ) True       = case unpackConFieldsCpr dc cpr of           AllFieldsSame field_cpr             | let sig = mkCprSig 0 field_cpr@@ -237,25 +224,55 @@ -- * CPR transformer -- -cprTransform :: AnalEnv         -- ^ The analysis environment-             -> Id              -- ^ The function-             -> CprType         -- ^ The demand type of the function-cprTransform env id-  = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig])+cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr)+cprAnalApp env e args' arg_tys+  -- Collect CprTypes for (value) args (inlined collectArgs):+  | App fn arg <- e, isTypeArg arg -- Don't analyse Type args+  = cprAnalApp env fn (arg:args') arg_tys+  | App fn arg <- e+  , (arg_ty, arg') <- cprAnal env arg+  = cprAnalApp env fn (arg':args') (arg_ty:arg_tys)++  | Var fn <- e+  = (cprTransform env fn arg_tys, mkApps e args')++  | otherwise -- e is not an App and not a Var+  , (e_ty, e') <- cprAnal env e+  = (applyCprTy e_ty (length arg_tys), mkApps e' args')++cprTransform :: AnalEnv   -- ^ The analysis environment+             -> Id        -- ^ The function+             -> [CprType] -- ^ info about incoming /value/ arguments+             -> CprType   -- ^ The demand type of the application+cprTransform env id args+  = -- pprTrace "cprTransform" (vcat [ppr id, ppr args, ppr sig])     sig   where     sig-      -- Top-level binding, local let-binding or case binder+      -- Top-level binding, local let-binding, lambda arg or case binder       | Just sig <- lookupSigEnv env id-      = getCprSig sig+      = applyCprTy (getCprSig sig) (length args)+      -- CPR transformers for special Ids+      | Just cpr_ty <- cprTransformSpecial id args+      = cpr_ty       -- See Note [CPR for data structures]       | Just rhs <- cprDataStructureUnfolding_maybe id       = fst $ cprAnal env rhs       -- Imported function or data con worker       | isGlobalId id-      = getCprSig (idCprSig id)+      = applyCprTy (getCprSig (idCprSig id)) (length args)       | otherwise       = topCprType++-- | CPR transformers for special Ids+cprTransformSpecial :: Id -> [CprType] -> Maybe CprType+cprTransformSpecial id args+  -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep+  | idUnique id == runRWKey -- `runRW (\s -> e)`+  , [arg] <- args           -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)+  = Just $ applyCprTy arg 1 -- `e` has CPR type `2`+  | otherwise+  = Nothing  -- -- * Bindings
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -7,7 +7,6 @@                         ----------------- -} -{-# LANGUAGE CPP #-}  module GHC.Core.Opt.DmdAnal    ( DmdAnalOpts(..)@@ -15,8 +14,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core.Opt.WorkWrap.Utils@@ -40,6 +37,7 @@ import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Maybe         ( isJust ) import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )@@ -276,7 +274,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body'))   where     WithDmdType body_ty body'   = anal_body env-    WithDmdType body_ty' id_dmd = findBndrDmd env notArgOfDfun body_ty id+    WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id     !id'                = setBindIdDemandInfo top_lvl id id_dmd     (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs @@ -344,7 +342,7 @@             -> (PlusDmdArg, CoreExpr) dmdAnalStar env (n :* cd) e   | WithDmdType dmd_ty e'    <- dmdAnal env cd e-  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )+  = assertPpr (not (isUnliftedType (exprType e)) || exprOkForSpeculation e) (ppr e)     -- The argument 'e' should satisfy the let/app invariant     -- See Note [Analysing with absent demand] in GHC.Types.Demand     (toPlusDmdArg $ multDmdType n dmd_ty, e')@@ -414,7 +412,7 @@           -- body_dmd: a demand to analyze the body          WithDmdType body_ty body' = dmdAnal env body_dmd body-        WithDmdType lam_ty var'   = annotateLamIdBndr env notArgOfDfun body_ty var+        WithDmdType lam_ty var'   = annotateLamIdBndr env body_ty var         new_dmd_type = multDmdType n lam_ty     in     WithDmdType new_dmd_type (Lam var' body')@@ -426,7 +424,7 @@   = let         WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs         WithDmdType alt_ty1 dmds          = findBndrsDmds env rhs_ty bndrs-        WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env False alt_ty1 case_bndr+        WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr         -- Evaluation cardinality on the case binder is irrelevant and a no-op.         -- What matters is its nested sub-demand!         (_ :* case_bndr_sd)      = case_bndr_dmd@@ -443,7 +441,7 @@           | otherwise           -- __DEFAULT and literal alts. Simply add demands and discard the           -- evaluation cardinality, as we evaluate the scrutinee exactly once.-          = ASSERT( null bndrs ) (bndrs, case_bndr_sd)+          = assert (null bndrs) (bndrs, case_bndr_sd)         fam_envs                 = ae_fam_envs env         alt_ty3           -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"@@ -1264,14 +1262,14 @@ dictionaries. -} -setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]-setBndrsDemandInfo (b:bs) (d:ds)-  | isTyVar b = b : setBndrsDemandInfo bs (d:ds)-  | otherwise =+setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var]+setBndrsDemandInfo (b:bs) ds+  | isTyVar b = b : setBndrsDemandInfo bs ds+setBndrsDemandInfo (b:bs) (d:ds) =     let !new_info = setIdDemandInfo b d         !vars = setBndrsDemandInfo bs ds     in new_info : vars-setBndrsDemandInfo [] ds = ASSERT( null ds ) []+setBndrsDemandInfo [] ds = assert (null ds) [] setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)  annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var@@ -1284,19 +1282,18 @@   | otherwise = WithDmdType dmd_ty  var   where     new_id = setIdDemandInfo var dmd-    WithDmdType dmd_ty' dmd = findBndrDmd env False dmd_ty var+    WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty var  annotateLamIdBndr :: AnalEnv-                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?                   -> DmdType    -- Demand type of body                   -> Id         -- Lambda binder                   -> WithDmdType Id  -- Demand type of lambda                                      -- and binder annotated with demand -annotateLamIdBndr env arg_of_dfun dmd_ty id+annotateLamIdBndr env dmd_ty id -- For lambdas we add the demand to the argument demands -- Only called for Ids-  = ASSERT( isId id )+  = assert (isId id) $     -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $     WithDmdType final_ty new_id   where@@ -1309,7 +1306,7 @@                              (unf_ty, _) = dmdAnalStar env dmd unf      main_ty = addDemand dmd dmd_ty'-    WithDmdType dmd_ty' dmd = findBndrDmd env arg_of_dfun dmd_ty id+    WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id  {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1396,10 +1393,6 @@ ************************************************************************ -} -type DFunFlag = Bool  -- indicates if the lambda being considered is in the-                      -- sequence of lambdas at the top of the RHS of a dfun-notArgOfDfun :: DFunFlag-notArgOfDfun = False  data AnalEnv = AE    { ae_strict_dicts :: !Bool -- ^ Enable strict dict@@ -1466,13 +1459,13 @@     go dmd_ty []  = WithDmdType dmd_ty []     go dmd_ty (b:bs)       | isId b    = let WithDmdType dmd_ty1 dmds = go dmd_ty bs-                        WithDmdType dmd_ty2 dmd  = findBndrDmd env False dmd_ty1 b+                        WithDmdType dmd_ty2 dmd  = findBndrDmd env dmd_ty1 b                     in WithDmdType dmd_ty2  (dmd : dmds)       | otherwise = go dmd_ty bs -findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> WithDmdType Demand+findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type]-findBndrDmd env arg_of_dfun dmd_ty id+findBndrDmd env dmd_ty id   = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $     WithDmdType dmd_ty' dmd'   where@@ -1484,19 +1477,62 @@     id_ty = idType id      strictify dmd+      -- See Note [Making dictionaries strict]       | ae_strict_dicts env              -- We never want to strictify a recursive let. At the moment              -- annotateBndr is only call for non-recursive lets; if that              -- changes, we need a RecFlag parameter and another guard here.-      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]       = strictifyDictDmd id_ty dmd       | otherwise       = dmd      fam_envs = ae_fam_envs env -{- Note [Initialising strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Making dictionaries strict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?++* Generally CBV is more efficient.++* Dictionaries are always non-bottom; and never take much work to+  compute.  E.g. a dfun from an instance decl always returns a dicionary+  record immediately.  See DFunUnfolding in CoreSyn.+  See also Note [Recursive superclasses] in TcInstDcls.++* The strictness analyser will then unbox dictionaries and pass the+  methods individually, rather than in a bundle.  If there are a lot of+  methods that might be bad; but worker/wrapper already does throttling.++* A newtype dictionary is *not* always non-bottom.  E.g.+      class C a where op :: a -> a+      instance C Int where op = error "urk"+  Now a value of type (C Int) is just a newtype wrapper (a cast) around+  the error thunk.  Don't strictify these!++See #17758 for more background and perf numbers.++The implementation is extremly simple: just make the strictness+analyser strictify the demand on a dictionary binder in+'findBndrDmd'.++However there is one case where this can make performance worse.+For the principle consider some function at the core level:+    myEq :: Eq a => a -> a -> Bool+    myEq eqDict x y = ((==) eqDict) x y+If we make the dictionary strict then WW can fire turning this into:+    $wmyEq :: (a -> a -> Bool) -> a -> a -> Bool+    $wmyEq eq x y = eq x y+Which *usually* performs better. However if the dictionary is known we+are far more likely to inline a function applied to the dictionary than+to inline one applied to a function. Sometimes this makes just enough+of a difference to stop a function from inlining. This is documented in+#18421.++It's somewhat similar to Note [Do not unpack class dictionaries] although+here our problem is with the inliner, not the specializer.++Note [Initialising strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See section 9.2 (Finding fixpoints) of the paper.  Our basic plan is to initialise the strictness of each Id in a
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -12,14 +12,12 @@ then discover that they aren't needed in the chosen branch. -} -{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -fprof-auto #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Core.Opt.FloatIn ( floatInwards ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -42,6 +40,7 @@  import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  {- Top-level interface function, @floatInwards@.  Note that we do not@@ -151,7 +150,7 @@  fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)                                        -- See Note [Dead bindings]-fiExpr _ to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty+fiExpr _ to_drop (_, AnnType ty)     = assert (null to_drop) $ Type ty fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v) fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) fiExpr platform to_drop (_, AnnCast expr (co_ann, co))@@ -701,7 +700,7 @@   = [] : [[] | _ <- drop_pts]    | otherwise-  = ASSERT( drop_pts `lengthAtLeast` 2 )+  = assert (drop_pts `lengthAtLeast` 2) $     go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))   where     n_alts = length drop_pts
compiler/GHC/Core/Opt/FloatOut.hs view
@@ -6,8 +6,8 @@ ``Long-distance'' floating of bindings towards the top level. -} -{-# LANGUAGE CPP #-} + module GHC.Core.Opt.FloatOut ( floatOutwards ) where  import GHC.Prelude@@ -35,8 +35,6 @@  import Data.List        ( partition ) -#include "GhclibHsVersions.h"- {-         -----------------         Overall game plan@@ -629,8 +627,8 @@  flattenTopFloats :: FloatBinds -> Bag CoreBind flattenTopFloats (FB tops ceils defs)-  = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )-    ASSERT2( isEmptyBag ceils, ppr ceils )+  = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $+    assertPpr (isEmptyBag ceils) (ppr ceils)     tops  addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
compiler/GHC/Core/Opt/LiberateCase.hs view
@@ -4,10 +4,8 @@ \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} -} -{-# LANGUAGE CPP #-}-module GHC.Core.Opt.LiberateCase ( liberateCase ) where -#include "GhclibHsVersions.h"+module GHC.Core.Opt.LiberateCase ( liberateCase ) where  import GHC.Prelude
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -8,8 +8,6 @@  module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -52,9 +50,9 @@ import qualified GHC.Utils.Error as Err import GHC.Utils.Error  ( withTiming ) import GHC.Utils.Logger as Logger-import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)  import GHC.Unit.External import GHC.Unit.Module.Env@@ -111,7 +109,7 @@   where     logger         = hsc_logger hsc_env     dflags         = hsc_dflags hsc_env-    home_pkg_rules = hptRules hsc_env (dep_mods deps)+    home_pkg_rules = hptRules hsc_env (dep_direct_mods deps)     hpt_rule_base  = mkRuleBase home_pkg_rules     print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.@@ -745,12 +743,12 @@         -- iteration_no is the number of the iteration we are         -- about to begin, with '1' for the first       | iteration_no > max_iterations   -- Stop if we've run out of iterations-      = WARN( debugIsOn && (max_iterations > 2)-            , hang (text "Simplifier bailing out after" <+> int max_iterations+      = warnPprTrace (debugIsOn && (max_iterations > 2))+            ( hang (text "Simplifier bailing out after" <+> int max_iterations                     <+> text "iterations"                     <+> (brackets $ hsep $ punctuate comma $                          map (int . simplCountN) (reverse counts_so_far)))-                 2 (text "Size =" <+> ppr (coreBindsStats binds)))+                 2 (text "Size =" <+> ppr (coreBindsStats binds))) $                  -- Subtract 1 from iteration_no to get the                 -- number of iterations we actually completed@@ -1050,8 +1048,7 @@     then         if hasShortableIdInfo exported_id         then True       -- See Note [Messing up the exported Id's IdInfo]-        else WARN( True, text "Not shorting out:" <+> ppr exported_id )-             False+        else warnPprTrace True (text "Not shorting out:" <+> ppr exported_id) False     else         False
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP             #-}+ {-# LANGUAGE PatternSynonyms #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -75,8 +75,6 @@         incMinorLvl, ltMajLvl, ltLvl, isTopLvl     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Ppr@@ -120,6 +118,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Types.Unique.DFM import GHC.Utils.FV@@ -1052,7 +1051,7 @@   = go e (count isId abs_vars)   where     go (Var {}) n    = n >= 0-    go (Lit lit) n   = ASSERT( n==0 )+    go (Lit lit) n   = assert (n==0) $                        litIsTrivial lit   -- Note [Floating literals]     go (Tick t e) n  = not (tickishIsCode t) && go e n     go (Cast e _)  n = go e n@@ -1690,9 +1689,9 @@          -- We are going to lambda-abstract, so nuke any IdInfo,         -- and add the tyvars of the Id (if necessary)-    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||-                           not (isEmptyRuleInfo (idSpecialisation v)),-                           text "absVarsOf: discarding info on" <+> ppr v )+    zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) ||+                           not (isEmptyRuleInfo (idSpecialisation v)))+                           (text "absVarsOf: discarding info on" <+> ppr v) $                      setIdInfo v vanillaIdInfo           | otherwise = v @@ -1708,7 +1707,7 @@ 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.+ = 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@@ -1807,7 +1806,7 @@ add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr) add_id id_env (v, v1)   | isTyVar v = delVarEnv    id_env v-  | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)+  | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1)  {- Note [Zapping the demand info]
compiler/GHC/Core/Opt/Simplify.hs view
@@ -4,14 +4,12 @@ \section[Simplify]{The main module of the simplifier} -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -65,8 +63,9 @@ import Control.Monad import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString-import GHC.Utils.Misc import GHC.Unit.Module ( moduleName, pprModuleName ) import GHC.Core.Multiplicity import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )@@ -293,7 +292,7 @@    | Just cont <- mb_cont   = {-#SCC "simplRecOrTopPair-join" #-}-    ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )+    assert (isNotTopLevel top_lvl && isJoinId new_bndr )     trace_bind "join" $     simplJoinBind env cont old_bndr new_bndr rhs env @@ -328,8 +327,8 @@ -- Precondition: rhs obeys the let/app invariant -- NOT used for JoinIds simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se-  = ASSERT( isId bndr )-    ASSERT2( not (isJoinId bndr), ppr bndr )+  = assert (isId bndr )+    assertPpr (not (isJoinId bndr)) (ppr bndr) $     -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $     do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]                 (tvs, body) = case collectTyAndValBinders rhs of@@ -415,7 +414,7 @@ -- Precondition: rhs satisfies the let/app invariant  simplNonRecX env bndr new_rhs-  | ASSERT2( not (isJoinId bndr), ppr bndr )+  | assertPpr (not (isJoinId bndr)) (ppr bndr) $     isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }   = return (emptyFloats env, env)    --  Here c is dead, and we avoid                                          --  creating the binding c = (a,b)@@ -444,7 +443,7 @@ --               See Note [Core let/app invariant] in GHC.Core  completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs-  = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )+  = assertPpr (not (isJoinId new_bndr)) (ppr new_bndr) $     do  { (prepd_floats, new_bndr, new_rhs)               <- prepareBinding env top_lvl old_bndr new_bndr new_rhs         ; let floats = emptyFloats env `addLetFloats` prepd_floats@@ -805,7 +804,7 @@      _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))   | otherwise- = ASSERT( isId new_bndr )+ = assert (isId new_bndr) $    do { let old_info = idInfo old_bndr             old_unf  = unfoldingInfo old_info             occ_info = occInfo old_info@@ -1096,7 +1095,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont   | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)   = {-#SCC "simplExprF1-NonRecLet-Type" #-}-    ASSERT( isTyVar bndr )+    assert (isTyVar bndr) $     do { ty' <- simplType env ty        ; simplExprF (extendTvSubst env bndr ty') body cont } @@ -1554,9 +1553,11 @@ -- Used for lambda binders.  These sometimes have unfoldings added by -- the worker/wrapper pass that must be preserved, because they can't -- be reconstructed from context.  For example:---      f x = case x of (a,b) -> fw a b x---      fw a b x{=(a,b)} = ...--- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.+--      f x = case x of StrictPair a b -> fw a b x+--      fw a{=OtherCon[]} b{=OtherCon[]} x{=(StrictPair a b)} = ...+-- The "{=(StrictPair a b)}" is an unfolding we can't reconstruct otherwise.+-- Since simplBinder already retains OtherCon bindings we only have to special+-- case core unfoldings like the one for `x`. simplLamBndr env bndr   | isId bndr && hasCoreUnfolding old_unf   -- Special case   = do { (env1, bndr1) <- simplBinder env bndr@@ -1603,7 +1604,7 @@ --       the call to simplLam in simplExprF (Lam ...)  simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont-  | ASSERT( isId bndr && not (isJoinId bndr) ) True+  | assert (isId bndr && not (isJoinId bndr) ) True   , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se   = do { tick (PreInlineUnconditionally bndr)        ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $@@ -1637,7 +1638,7 @@ --  * non-top-level recursive lets in expressions simplRecE env pairs body cont   = do  { let bndrs = map fst pairs-        ; MASSERT(all (not . isJoinId) bndrs)+        ; massert (all (not . isJoinId) bndrs)         ; env1 <- simplRecBndrs env bndrs                 -- NB: bndrs' don't have unfoldings or rules                 -- We add them as we go down@@ -1743,7 +1744,7 @@                      -> InExpr -> SimplCont                      -> SimplM (SimplFloats, OutExpr) simplNonRecJoinPoint env bndr rhs body cont-  | ASSERT( isJoinId bndr ) True+  | assert (isJoinId bndr ) True   , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env   = do { tick (PreInlineUnconditionally bndr)        ; simplExprF env' body cont }@@ -2201,7 +2202,7 @@                 -- Takes   K -> e  into   tagK# -> e                 -- where tagK# is the tag of constructor K              enum_to_tag (DataAlt con, [], rhs)-               = ASSERT( isEnumerationTyCon (dataConTyCon con) )+               = assert (isEnumerationTyCon (dataConTyCon con) )                 (LitAlt tag, [], rhs)               where                 tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))@@ -2677,7 +2678,7 @@         }   where     simple_rhs env wfloats scrut' bs rhs =-      ASSERT( null bs )+      assert (null bs) $       do { (floats1, env') <- simplNonRecX env case_bndr scrut'              -- scrut is a constructor application,              -- hence satisfies let/app invariant@@ -2976,7 +2977,7 @@          -> SimplM OutAlt  simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)-  = ASSERT( null bndrs )+  = assert (null bndrs) $     do  { let env' = addBinderUnfolding env case_bndr'                                         (mkOtherCon imposs_deflt_cons)                 -- Record the constructors that the case-binder *can't* be.@@ -2984,7 +2985,7 @@         ; return (Alt DEFAULT [] rhs') }  simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)-  = ASSERT( null bndrs )+  = assert (null bndrs) $     do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)         ; rhs' <- simplExprC env' rhs cont'         ; return (Alt (LitAlt lit) [] rhs') }@@ -3095,9 +3096,9 @@ addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv addBinderUnfolding env bndr unf   | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf-  = WARN( not (eqType (idType bndr) (exprType tmpl)),-          ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )-    modifyInScope env (bndr `setIdUnfolding` unf)+  = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))+          (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $+          modifyInScope env (bndr `setIdUnfolding` unf)    | otherwise   = modifyInScope env (bndr `setIdUnfolding` unf)@@ -3210,15 +3211,15 @@     bind_args env' [] _  = return (emptyFloats env', env')      bind_args env' (b:bs') (Type ty : args)-      = ASSERT( isTyVar b )+      = assert (isTyVar b )         bind_args (extendTvSubst env' b ty) bs' args      bind_args env' (b:bs') (Coercion co : args)-      = ASSERT( isCoVar b )+      = assert (isCoVar b )         bind_args (extendCvSubst env' b co) bs' args      bind_args env' (b:bs') (arg : args)-      = ASSERT( isId b )+      = assert (isId b) $         do { let b' = zap_occ b              -- Note that the binder might be "dead", because it doesn't              -- occur in the RHS; and simplNonRecX may therefore discard@@ -3261,7 +3262,7 @@                 -- it "sees" that the entire branch of an outer case is                 -- inaccessible.  So we simply put an error case here instead. missingAlt env case_bndr _ cont-  = WARN( True, text "missingAlt" <+> ppr case_bndr )+  = warnPprTrace True (text "missingAlt" <+> ppr case_bndr) $     -- See Note [Avoiding space leaks in OutType]     let cont_ty = contResultType cont     in seqType cont_ty `seq`@@ -3530,9 +3531,9 @@                              unf = mkInlineUnfolding simpl_opts rhs                              rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' -                      LitAlt {} -> WARN( True, text "mkDupableAlt"-                                                <+> ppr case_bndr <+> ppr con )-                                   case_bndr+                      LitAlt {} -> warnPprTrace True+                                    (text "mkDupableAlt" <+> ppr case_bndr <+> ppr con)+                                    case_bndr                            -- The case binder is alive but trivial, so why has                            -- it not been substituted away? @@ -4054,8 +4055,7 @@            ; let rhs_ty = substTy env' (exprType rhs)                  rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]                                 Nothing   -> mkBoringStop rhs_ty-                                Just cont -> ASSERT2( join_ok, bad_join_msg )-                                             cont+                                Just cont -> assertPpr join_ok bad_join_msg cont                  lhs_env = updMode updModeForRules env'                  rhs_env = updMode (updModeForStableUnfoldings act) env'                            -- See Note [Simplifying the RHS of a RULE]
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -4,8 +4,8 @@ \section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} -} -{-# LANGUAGE CPP #-} + module GHC.Core.Opt.Simplify.Env (         -- * The simplifier mode         setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger,@@ -43,8 +43,6 @@         wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core.Opt.Simplify.Monad@@ -70,6 +68,7 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Types.Unique.FM      ( pprUniqFM )@@ -336,17 +335,17 @@ --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res-  = ASSERT2( isId var && not (isCoVar var), ppr var )+  = assertPpr (isId var && not (isCoVar var)) (ppr var) $     env { seIdSubst = extendVarEnv subst var res }  extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res-  = ASSERT2( isTyVar var, ppr var $$ ppr res )+  = assertPpr (isTyVar var) (ppr var $$ ppr res) $     env {seTvSubst = extendVarEnv tsubst var res}  extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co-  = ASSERT( isCoVar var )+  = assert (isCoVar var) $     env {seCvSubst = extendVarEnv csubst var co}  ---------------------@@ -516,7 +515,7 @@  unitLetFloat :: OutBind -> LetFloats -- This key function constructs a singleton float with the right form-unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))+unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $                     LetFloats (unitOL bind) (flag bind)   where     flag (Rec {})                = FltLifted@@ -526,12 +525,12 @@           -- String literals can be floated freely.           -- See Note [Core top-level string literals] in GHC.Core.       | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)-      | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )+      | otherwise                = assertPpr (not (isUnliftedType (idType bndr))) (ppr bndr)                                    FltCareful       -- Unlifted binders can only be let-bound if exprOkForSpeculation holds  unitJoinFloat :: OutBind -> JoinFloats-unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))+unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $                      unitOL bind  mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)@@ -618,7 +617,7 @@ mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs _ff                                 , sfJoinFloats = jbs                                 , sfInScope    = in_scope })-  = ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )+  = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $     SimplFloats { sfLetFloats  = floats'                 , sfJoinFloats = jfloats'                 , sfInScope    = in_scope }@@ -654,7 +653,7 @@ getTopFloatBinds :: SimplFloats -> [CoreBind] getTopFloatBinds (SimplFloats { sfLetFloats  = lbs                               , sfJoinFloats = jbs})-  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings+  = assert (isNilOL jbs) $  -- Can't be any top-level join bindings     letFloatBinds lbs  {-# INLINE mapLetFloats #-}@@ -786,7 +785,7 @@ -- Recursive let binders simplRecBndrs env@(SimplEnv {}) ids   -- See Note [Bangs in the Simplifier]-  = ASSERT(all (not . isJoinId) ids)+  = assert (all (not . isJoinId) ids) $     do  { let (!env1, ids1) = mapAccumL substIdBndr env ids         ; seqIds ids1 `seq` return env1 } @@ -832,7 +831,7 @@               -> (SimplEnv, OutBndr) subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })               old_id adjust_type-  = ASSERT2( not (isCoVar old_id), ppr old_id )+  = assertPpr (not (isCoVar old_id)) (ppr old_id)     (env { seInScope = new_in_scope,            seIdSubst = new_subst }, new_id)     -- It's important that both seInScope and seIdSubst are updated with@@ -933,7 +932,7 @@ -- context being pushed inward may change types -- See Note [Return type for join points] simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty-  = ASSERT(all isJoinId ids)+  = assert (all isJoinId ids) $     do  { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids         ; seqIds ids1 `seq` return env1 } @@ -960,7 +959,7 @@ -- INVARIANT: If any of the first n binders are foralls, those tyvars -- cannot appear in the original result type. See isValidJoinPointType. adjustJoinPointType mult new_res_ty join_id-  = ASSERT( isJoinId join_id )+  = assert (isJoinId join_id) $     setIdType join_id new_join_ty   where     orig_ar = idJoinArity join_id
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -4,8 +4,8 @@ The simplifier utilities -} -{-# LANGUAGE CPP #-} + module GHC.Core.Opt.Simplify.Utils (         -- Rebuilding         mkLam, mkCase, prepareAlts, tryEtaExpandRhs,@@ -37,8 +37,6 @@         isExitJoinId     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core.Opt.Simplify.Env@@ -73,6 +71,7 @@ import GHC.Utils.Outputable import GHC.Utils.Logger import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Core.Opt.ConstantFold import GHC.Data.FastString ( fsLit ) @@ -563,8 +562,8 @@                    else                         demands ++ vanilla_dmds                | otherwise-               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)-                                <+> ppr n_val_args <+> ppr demands )+               -> warnPprTrace True (text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)+                                <+> ppr n_val_args <+> ppr demands) $                   vanilla_dmds      -- Not enough args, or no strictness      add_type_strictness :: Type -> [Demand] -> [Demand]@@ -1928,8 +1927,8 @@ abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats               -> OutExpr -> SimplM ([OutBind], OutExpr) abstractFloats uf_opts top_lvl main_tvs floats body-  = ASSERT( notNull body_floats )-    ASSERT( isNilOL (sfJoinFloats floats) )+  = assert (notNull body_floats) $+    assert (isNilOL (sfJoinFloats floats)) $     do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats         ; return (float_binds, GHC.Core.Subst.substExpr subst body) }   where@@ -2252,7 +2251,7 @@   , inner_scrut_var == outer_bndr   = do  { tick (CaseMerge outer_bndr) -        ; let wrap_alt (Alt con args rhs) = ASSERT( outer_bndr `notElem` args )+        ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args)                                             (Alt con args (wrap_rhs rhs))                 -- Simplifier's no-shadowing invariant should ensure                 -- that outer_bndr is not shadowed by the inner patterns
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -10,8 +10,8 @@ \section[SpecConstr]{Specialise over constructors} -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Core.Opt.SpecConstr(@@ -19,8 +19,6 @@         SpecConstrAnnotation(..)     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core@@ -57,7 +55,8 @@ import GHC.Data.Pair import GHC.Types.Unique.Supply import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString import GHC.Types.Unique.FM import GHC.Utils.Monad@@ -1342,7 +1341,7 @@ scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)  scApp env (Var fn, args)        -- Function is a variable-  = ASSERT( not (null args) )+  = assert (not (null args)) $     do  { args_w_usgs <- mapM (scExpr env) args         ; let (arg_usgs, args') = unzip args_w_usgs               arg_usg = combineUsages arg_usgs@@ -1719,30 +1718,27 @@                  -- And build the results         ; let spec_body_ty   = exprType spec_body-              spec_lam_args1 = qvars ++ extra_bndrs-              (spec_lam_args, spec_call_args) = mkWorkerArgs False-                                                             spec_lam_args1 spec_body_ty++              (spec_lam_args1, spec_sig, spec_arity, spec_join_arity)+                  = calcSpecInfo fn call_pat extra_bndrs+                  -- Annotate the variables with the strictness information from+                  -- the function (see Note [Strictness information in worker binders])++              (spec_lam_args, spec_call_args) = mkWorkerArgs fn False+                                                    spec_lam_args1 spec_body_ty                 -- mkWorkerArgs: usual w/w hack to avoid generating                 -- a spec_rhs of unlifted type and no args -              spec_str          = calcSpecStrictness fn spec_lam_args pats-              spec_lam_args_str = handOutStrictnessInformation spec_str spec_lam_args-                -- Annotate the variables with the strictness information from-                -- the function (see Note [Strictness information in worker binders])--              spec_join_arity | isJoinId fn = Just (length spec_lam_args)-                              | otherwise   = Nothing               spec_id    = mkLocalId spec_name Many                                      (mkLamTypes spec_lam_args spec_body_ty)                              -- See Note [Transfer strictness]-                             `setIdDmdSig` spec_str-                             `setIdCprSig` topCprSig-                             `setIdArity` count isId spec_lam_args+                             `setIdDmdSig`    spec_sig+                             `setIdCprSig`    topCprSig+                             `setIdArity`     spec_arity                              `asJoinId_maybe` spec_join_arity -                 -- Conditionally use result of new worker-wrapper transform-              spec_rhs   = mkLams spec_lam_args_str spec_body+              spec_rhs   = mkLams spec_lam_args spec_body               rule_rhs   = mkVarApps (Var spec_id) $                            dropTail (length extra_bndrs) spec_call_args               inline_act = idInlineActivation fn@@ -1755,31 +1751,46 @@                                , os_rhs = spec_rhs }) }  +calcSpecInfo :: Id                     -- The original function+             -> CallPat                -- Call pattern+             -> [Var]                  -- Extra bndrs+             -> ( [Var]                     -- Demand-decorated binders+                , DmdSig                    -- Strictness of specialised thing+                , Arity, Maybe JoinArity )  -- Arities of specialised thing+-- Calcuate bits of IdInfo for the specialised function+-- See Note [Transfer strictness] -- See Note [Strictness information in worker binders]-handOutStrictnessInformation :: DmdSig -> [Var] -> [Var]-handOutStrictnessInformation str vs-  = go (fst (splitDmdSig str)) vs+calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs+  | isJoinId fn    -- Join points have strictness and arity for LHS only+  = ( bndrs_w_dmds+    , mkClosedDmdSig qvar_dmds div+    , count isId qvars+    , Just (length qvars) )+  | otherwise+  = ( bndrs_w_dmds+    , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div+    , count isId qvars + count isId extra_bndrs+    , Nothing )   where-    go _ [] = []-    go [] vs = vs-    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs-    go dmds (v:vs) = v : go dmds vs+    DmdSig (DmdType _ fn_dmds div) = idDmdSig fn -calcSpecStrictness :: Id                     -- The original function-                   -> [Var] -> [CoreExpr]    -- Call pattern-                   -> DmdSig                 -- Strictness of specialised thing--- See Note [Transfer strictness]-calcSpecStrictness fn qvars pats-  = mkClosedDmdSig spec_dmds div-  where-    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]-    DmdSig (DmdType _ dmds div) = idDmdSig fn+    val_pats   = filterOut isTypeArg pats+    qvar_dmds  = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+    extra_dmds = dropList val_pats fn_dmds -    dmd_env = go emptyVarEnv dmds pats+    bndrs_w_dmds =  set_dmds qvars       qvar_dmds+                 ++ set_dmds extra_bndrs extra_dmds +    set_dmds :: [Var] -> [Demand] -> [Var]+    set_dmds [] _   = []+    set_dmds vs  [] = vs  -- Run out of demands+    set_dmds (v:vs) ds@(d:ds') | isTyVar v = v                   : set_dmds vs ds+                               | otherwise = setIdDemandInfo v d : set_dmds vs ds'++    dmd_env = go emptyVarEnv fn_dmds val_pats+     go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv-    go env ds (Type {} : pats)     = go env ds pats-    go env ds (Coercion {} : pats) = go env ds pats+    -- We've filtered out all the type patterns already     go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats     go env _      _                = env @@ -1789,8 +1800,9 @@       | (Var _, args) <- collectArgs e       , Just ds <- viewProd (length args) cd       = go env ds args-    go_one env _               _       = env+    go_one env _  _ = env + {- Note [spec_usg includes rhs_usg] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1847,13 +1859,13 @@  Note [Strictness information in worker binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- After having calculated the strictness annotation for the worker (see Note [Transfer strictness] above), we also want to have this information attached to the worker’s arguments, for the benefit of later passes. The function handOutStrictnessInformation decomposes the strictness annotation calculated by calcSpecStrictness and attaches them to the variables. + ************************************************************************ *                                                                      * \subsection{Argument analysis}@@ -2164,9 +2176,9 @@               bad_covar v = isId v && not (is_in_scope v)          ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $-          WARN( not (isEmptyVarSet bad_covars)-              , text "SpecConstr: bad covars:" <+> ppr bad_covars-                $$ ppr call )+          warnPprTrace (not (isEmptyVarSet bad_covars))+              ( text "SpecConstr: bad covars:" <+> ppr bad_covars+                $$ ppr call) $           if interesting && isEmptyVarSet bad_covars           then return (Just (CP { cp_qvars = qvars', cp_args = pats }))           else return Nothing }@@ -2269,15 +2281,20 @@    -- Check if the argument is a variable that   --    (a) is used in an interesting way in the function body+  ---       i.e. ScrutOcc. UnkOcc and NoOcc are not interesting+  --        (NoOcc means we could drop the argument, but that's the+  --         business of absence analysis, not SpecConstr.)   --    (b) we know what its value is   -- In that case it counts as "interesting" argToPat env in_scope val_env (Var v) arg_occ-  | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)-    is_value,                                                            -- (b)+  | sc_force env || case arg_occ of { ScrutOcc {} -> True+                                    ; UnkOcc      -> False+                                    ; NoOcc       -> False } -- (a)+  , is_value                                                 -- (b)        -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]        -- So sc_keen focused just on f (I# x), where we have freshly-allocated        -- box that we can eliminate in the caller-    not (ignoreType env (varType v))+  , not (ignoreType env (varType v))   = return (True, Var v)   where     is_value@@ -2385,7 +2402,7 @@     same e1 (Tick _ e2) = same e1 e2     same e1 (Cast e2 _) = same e1 e2 -    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)+    same e1 e2 = warnPprTrace (bad e1 || bad e2) (ppr e1 $$ ppr e2) $                  False  -- Let, lambda, case should not occur     bad (Case {}) = True     bad (Let {})  = True
compiler/GHC/Core/Opt/Specialise.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  {-@@ -10,8 +10,6 @@  module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -809,6 +807,7 @@ tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () -- See Note [Warning about missed specialisations] tryWarnMissingSpecs dflags callers fn calls_for_fn+  | isClassOpId fn = return () -- See Note [Missed specialization for ClassOps]   | wopt Opt_WarnMissedSpecs dflags     && not (null callers)     && allCallersInlined                  = doWarn $ WarningWithFlag Opt_WarnMissedSpecs@@ -824,8 +823,41 @@           , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))           , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) +{- Note [Missed specialisation for ClassOps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19592 I saw a number of missed specialisation warnings+which were the result of things like: +    case isJumpishInstr @X86.Instr $dInstruction_s7f8 eta3_a78C of { ... +where isJumpishInstr is part of the Instruction class and defined like+this:++    class Instruction instr where+        ...+        isJumpishInstr :: instr -> Bool+        ...++isJumpishInstr is a ClassOp which will select the right method+from within the dictionary via our built in rules. See also+Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance.++We don't give these unfoldings, and as a result the specialiser+complains. But usually this doesn't matter. The simplifier will+apply the rule and we end up with++    case isJumpishInstrImplX86 eta3_a78C of { ...++Since isJumpishInstrImplX86 is defined for a concrete instance (given+by the dictionary) it is usually already well specialised!+Theoretically the implementation of a method could still be overloaded+over a different type class than what it's a method of. But I wasn't able+to make this go wrong, and SPJ thinks this should be fine as well.++So I decided to remove the warnings for failed specialisations on ClassOps+alltogether as they do more harm than good.+-}+ {- Note [Do not specialise imported DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ticket #18223 shows that specialising calls of DFuns is can cause a huge@@ -1406,8 +1438,8 @@     foldlM spec_call ([], [], emptyUDs) calls_for_me    | otherwise   -- No calls or RHS doesn't fit our preconceptions-  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,-          text "Missed specialisation opportunity for" <+> ppr fn $$ _trace_doc )+  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)+          (text "Missed specialisation opportunity for" <+> ppr fn $$ _trace_doc) $           -- Note [Specialisation shape]     -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $     return ([], [], emptyUDs)@@ -2560,7 +2592,7 @@ data CallInfo   = CI { ci_key  :: [SpecArg]   -- All arguments        , ci_fvs  :: IdSet       -- Free Ids of the ci_key call-                                -- *not* including the main id itself, of course+                                -- _not_ including the main id itself, of course                                 -- NB: excluding tyvars:                                 --     See Note [Specialising polymorphic dictionaries]     }
compiler/GHC/Core/Opt/StaticArgs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -73,8 +73,6 @@  import Data.List (mapAccumL) import GHC.Data.FastString--#include "GhclibHsVersions.h"  doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -4,7 +4,7 @@ \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} -} -{-# LANGUAGE CPP #-}+ module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where  import GHC.Prelude@@ -32,11 +32,10 @@ import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Core.FamInstEnv import GHC.Utils.Monad -#include "GhclibHsVersions.h"- {- We take Core bindings whose binders have: @@ -209,7 +208,7 @@ How do we "transfer the unfolding"? Easy: by using the old one, wrapped in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding. -Note [No worker-wrapper for record selectors]+Note [No worker/wrapper for record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes generate a lot of record selectors, and generally the don't benefit from worker/wrapper.  Yes, mkWwBodies would find a w/w split,@@ -495,10 +494,13 @@   -- See Note [Worker/wrapper for NOINLINE functions]    | Just stable_unf <- certainlyWillInline uf_opts fn_info-  = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]+  = return [ (new_fn_id `setIdUnfolding` stable_unf, rhs) ]         -- See Note [Don't w/w INLINE things]         -- See Note [Don't w/w inline small non-loop-breaker things] +  | isRecordSelector fn_id  -- See Note [No worker/wrapper for record selectors]+  = return [ (new_fn_id, rhs ) ]+   | is_fun && is_eta_exp   = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs @@ -516,8 +518,9 @@     cpr_ty       = getCprSig (cprSigInfo fn_info)     -- Arity of the CPR sig should match idArity when it's not a join point.     -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal-    cpr          = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info-                          , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info))+    cpr          = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info)+                             (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty)+                              <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $                    ct_cpr cpr_ty      new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)@@ -569,6 +572,32 @@ We do not do it in the demand analyser for the same reasons outlined in Note [Zapping DmdEnv after Demand Analyzer] above. +For example, consider+  let y = factorial v in+  let x = y in+  x + x++Demand analysis will conclude, correctly, that `y` is demanded once.  But if we inline `x` we get+  let y = factorial v in+  y + y++Similarly for+  f y = let x = y in x+x+where we will put a used-once demand on y, and hence also in f's demand signature.++And recursively+  f y = case y of (p,q) -> let p2 = p in p2+p2+ Here we'll get a used-once demand on p; but that is not robust to inlining p2.++Conclusion: "demanded once" info is fragile.+* We want it after the final immediately-before-code-gen demand analysis, so we can identify single-entry thunks.+* But we don't want it otherwise because it is not robust.++Conclusion: kill it during worker/wrapper, using `zapUsedOnceInfo`.  Both the *demand signature* of+the binder, and the *demand-info* of the binder.  Moreover, do so recursively.++(NB THE pre-code-gen demand analysis is not followed by worker/wrapper.)+ Note [Don't eta expand in w/w] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A binding where the manifestArity of the RHS is less than idArity of the binder@@ -605,26 +634,15 @@ splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr          -> UniqSM [(Id, CoreExpr)] splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs-  | isRecordSelector fn_id  -- See Note [No worker/wrapper for record selectors]-  = return [ (fn_id, rhs ) ]--  | otherwise-  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) )+  = warnPprTrace (not (wrap_dmds `lengthIs` arity)) (ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr)) $           -- The arity should match the signature     do { mb_stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_dmds use_cpr_info        ; case mb_stuff of             Nothing -> return [(fn_id, rhs)] -            Just stuff-              | Just stable_unf <- certainlyWillInline (unfoldingOpts dflags) fn_info-              ->  return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]-                  -- See Note [Don't w/w INLINE things]-                  -- See Note [Don't w/w inline small non-loop-breaker things]--              | otherwise-              -> do { work_uniq <- getUniqueM-                    ; return (mkWWBindPair dflags fn_id fn_info arity rhs-                                           work_uniq div cpr stuff) } }+            Just stuff -> do { work_uniq <- getUniqueM+                             ; return (mkWWBindPair dflags fn_id fn_info arity rhs+                                                    work_uniq div cpr stuff) } }   where     rhs_fvs = exprFreeVars rhs     arity   = arityInfo fn_info@@ -868,11 +886,11 @@ -- Note [Thunk splitting for top-level binders]. splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] splitThunk dflags fam_envs is_rec x rhs-  = ASSERT(not (isJoinId x))+  = assert (not (isJoinId x)) $     do { let x' = localiseId x -- See comment above        ; (useful,_, wrap_fn, work_fn)            <- mkWWstr (initWwOpts dflags fam_envs) NotArgOfInlineableFun [x']        ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ]-       ; if useful then ASSERT2( isNonRec is_rec, ppr x ) -- The thunk must be non-recursive+       ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive                    return res                    else return [(x, rhs)] }
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -4,7 +4,7 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE ViewPatterns #-}  module GHC.Core.Opt.WorkWrap.Utils@@ -16,8 +16,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core@@ -51,6 +49,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Data.FastString@@ -189,7 +188,8 @@         ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)               <- mkWWcpr_entry opts res_ty cpr_info -        ; let (work_lam_args, work_call_args) = mkWorkerArgs (wo_fun_to_thunk opts) work_args cpr_res_ty+        ; let (work_lam_args, work_call_args) = mkWorkerArgs fun_id (wo_fun_to_thunk opts)+                                                             work_args cpr_res_ty               worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]               wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var               worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args@@ -228,9 +228,9 @@     too_many_args_for_join_point wrap_args       | Just join_arity <- mb_join_arity       , wrap_args `lengthExceeds` join_arity-      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>+      = warnPprTrace True (text "Unable to worker/wrapper join point with arity " <+>                      int join_arity <+> text "but" <+>-                     int (length wrap_args) <+> text "args")+                     int (length wrap_args) <+> text "args") $         True       | otherwise       = False@@ -302,31 +302,39 @@ We use the state-token type which generates no code. -} -mkWorkerArgs :: Bool+mkWorkerArgs :: Id      -- The wrapper Id+             -> Bool              -> [Var]              -> Type    -- Type of body              -> ([Var], -- Lambda bound args                  [Var]) -- Args at call site-mkWorkerArgs fun_to_thunk args res_ty-    | any isId args || not needsAValueLambda-    = (args, args)-    | otherwise+mkWorkerArgs wrap_id fun_to_thunk args res_ty+    | not (isJoinId wrap_id) -- Join Ids never need an extra arg+    , not (any isId args)    -- No existing value lambdas+    , needs_a_value_lambda   -- and we need to add one     = (args ++ [voidArgId], args ++ [voidPrimId])++    | otherwise+    = (args, args)     where-      -- See "Making wrapper args" section above-      needsAValueLambda =-        lifted-        -- We may encounter a levity-polymorphic result, in which case we-        -- conservatively assume that we have laziness that needs preservation.-        -- See #15186.-        || not fun_to_thunk-           -- see Note [Protecting the last value argument]+      -- If fun_to_thunk is False we always keep at least one value+      --   argument: see Note [Protecting the last value argument]+      -- If it is True, we only need to keep a value argument if+      --   the result type is (or might be) unlifted, in which case+      --   dropping the last arg would mean we wrongly used call-by-value+      needs_a_value_lambda+        = not fun_to_thunk+          || might_be_unlifted        -- Might the result be lifted?-      lifted =-        case isLiftedType_maybe res_ty of-          Just lifted -> lifted-          Nothing     -> True+      --     False => definitely lifted+      --     True  => might be unlifted+      -- We may encounter a levity-polymorphic result, in which case we+      -- conservatively assume that we have laziness that needs+      -- preservation. See #15186.+      might_be_unlifted = case isLiftedType_maybe res_ty of+                            Just lifted -> not lifted+                            Nothing     -> True  {- Note [Protecting the last value argument]@@ -344,7 +352,6 @@  Note [Join points and beta-redexes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Originally, the worker would invoke the original function by calling it with arguments, thus producing a beta-redex for the simplifier to munch away: @@ -375,7 +382,6 @@  Note [Join points returning functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- It is crucial that the arity of a join point depends on its *callers,* not its own syntax. What this means is that a join point can have "extra lambdas": @@ -495,7 +501,7 @@                   res_ty) }    | otherwise-  = WARN( True, ppr fun_ty )                          -- Should not happen: if there is a demand+  = warnPprTrace True (ppr fun_ty) $                  -- Should not happen: if there is a demand     return ([], nop_fn, nop_fn, substTy subst fun_ty) -- then there should be a function arrow   where     -- See Note [Join points and beta-redexes]@@ -663,7 +669,7 @@    where     -- | See Note [non-algebraic or open body type warning]-    open_body_ty_warning = WARN( True, text "wantToUnboxResult: non-algebraic or open body type" <+> ppr ty ) Nothing+    open_body_ty_warning = warnPprTrace True (text "wantToUnboxResult: non-algebraic or open body type" <+> ppr ty) Nothing  isLinear :: Scaled a -> Bool isLinear (Scaled w _ ) =@@ -1017,7 +1023,7 @@   -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep.   -- See (3) in Note [Absent fillers]   | Nothing <- mb_mono_prim_reps-  = WARN( True, text "No absent value for" <+> ppr arg_ty )+  = warnPprTrace True (text "No absent value for" <+> ppr arg_ty) $     Nothing   where     arg_ty = idType arg@@ -1365,8 +1371,8 @@   return (False, toOL vars, nop_fn, nop_fn) mkWWcpr opts  vars cprs = do   -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that.-  MASSERT2( not (any isTyVar vars), ppr vars $$ ppr cprs )-  MASSERT2( equalLength vars cprs, ppr vars $$ ppr cprs )+  massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs)+  massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs)   (usefuls, varss, wrap_build_ress, work_unpack_ress) <-     unzip4 <$> zipWithM (mkWWcpr_one opts) vars cprs   return ( or usefuls@@ -1377,7 +1383,7 @@ mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResult -- ^ See if we want to unbox the result and hand off to 'unbox_one_result'. mkWWcpr_one opts res_bndr cpr-  | ASSERT( not (isTyVar res_bndr) ) True+  | assert (not (isTyVar res_bndr) ) True   , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr   = unbox_one_result opts res_bndr arg_cprs dcpc   | otherwise@@ -1397,7 +1403,7 @@   pat_bndrs_uniqs <- getUniquesM   let (_exs, arg_ids) =         dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args-  MASSERT( null _exs ) -- Should have been caught by wantToUnboxResult+  massert (null _exs) -- Should have been caught by wantToUnboxResult    let -- con_app = (C a b |> sym co)       con_app = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co
compiler/GHC/Core/TyCon/Set.hs view
@@ -4,8 +4,8 @@  -} -{-# LANGUAGE CPP #-} + module GHC.Core.TyCon.Set (         -- * TyCons set type         TyConSet,@@ -17,8 +17,6 @@         intersectsTyConSet, disjointTyConSet, intersectTyConSet,         nameSetAny, nameSetAll     ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CoreToStg.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} @@ -15,8 +15,6 @@  module GHC.CoreToStg ( coreToStg ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core@@ -43,9 +41,10 @@ import GHC.Types.Literal import GHC.Utils.Outputable import GHC.Utils.Monad+import GHC.Utils.Misc (HasDebugCallStack) import GHC.Data.FastString-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Driver.Session import GHC.Platform.Ways import GHC.Driver.Ppr@@ -311,7 +310,7 @@     (env', ccs', bind)  coreTopBindToStg dflags this_mod env ccs (Rec pairs)-  = ASSERT( not (null pairs) )+  = assert (not (null pairs)) $     let         binders = map fst pairs @@ -344,7 +343,7 @@              stg_arity =                stgRhsArity stg_rhs -       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,+       ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs,                  ccs') }   where         -- It's vital that the arity on a top-level Id matches@@ -375,7 +374,7 @@ -- handle with the function coreToPreStgRhs.  coreToStgExpr-        :: CoreExpr+        :: HasDebugCallStack => CoreExpr         -> CtsM StgExpr  -- The second and third components can be derived in a simple bottom up pass, not@@ -389,17 +388,18 @@ coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger" coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural" coreToStgExpr (Lit l)                           = return (StgLit l)-coreToStgExpr (App l@(Lit LitRubbish{}) Type{}) = coreToStgExpr l coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _)   -- See Note [Coercion tokens]   = coreToStgApp coercionTokenId [] []  coreToStgExpr expr@(App _ _)-  = coreToStgApp f args ticks-  where-    (f, args, ticks) = myCollectArgs expr-+  = case app_head of+      Var f               -> coreToStgApp f args ticks -- Regular application+      Lit l@LitRubbish{}  -> return (StgLit l) -- LitRubbish+      _                   -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)+    where+      (app_head, args, ticks) = myCollectArgs expr coreToStgExpr expr@(Lam _ _)   = let         (args, body) = myCollectBinders expr@@ -455,7 +455,7 @@       = -- This case is a bit smelly.         -- See Note [Nullary unboxed tuple] in GHC.Core.Type         -- where a nullary tuple is mapped to (State# World#)-        ASSERT( null binders )+        assert (null binders) $         do { rhs2 <- coreToStgExpr rhs            ; return (DEFAULT, [], rhs2)  }       | otherwise@@ -481,8 +481,7 @@           Just tc             | isAbstractTyCon tc -> look_for_better_tycon             | isAlgTyCon tc      -> AlgAlt tc-            | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )-                                    PolyAlt+            | otherwise          -> assertPpr (_is_poly_alt_tycon tc) (ppr tc) PolyAlt           Nothing                -> PolyAlt       [non_gcd] -> PrimAlt non_gcd       not_unary -> MultiValAlt (length not_unary)@@ -505,7 +504,7 @@         | ((Alt (DataAlt con) _ _) : _) <- data_alts =                 AlgAlt (dataConTyCon con)         | otherwise =-                ASSERT(null data_alts)+                assert (null data_alts)                 PolyAlt         where                 (data_alts, _deflt) = findDefault alts@@ -544,17 +543,17 @@                 -- Some primitive operator that might be implemented as a library call.                 -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps                 -- we require that primop applications be saturated.-                PrimOpId op      -> ASSERT( saturated )+                PrimOpId op      -> assert saturated $                                     StgOpApp (StgPrimOp op) args' res_ty                  -- A call to some primitive Cmm function.                 FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)                                           PrimCallConv _))-                                 -> ASSERT( saturated )+                                 -> assert saturated $                                     StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty                  -- A regular foreign call.-                FCallId call     -> ASSERT( saturated )+                FCallId call     -> assert saturated $                                     StgOpApp (StgFCallOp call (idType f)) args' res_ty                  TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')@@ -585,7 +584,7 @@        ; return (StgVarArg coercionTokenId : args', ts) }  coreToStgArgs (Tick t e : args)-  = ASSERT( not (tickishIsCode t) )+  = assert (not (tickishIsCode t)) $     do { (args', ts) <- coreToStgArgs (e : args)        ; let !t' = coreToStgTick (exprType e) t        ; return (args', t':ts) }@@ -617,7 +616,7 @@         stg_arg_rep = typePrimRep (stgArgType stg_arg)         bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) -    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )+    warnPprTrace bad_args (text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg) $      return (stg_arg : stg_args, ticks ++ aticks)  coreToStgTick :: Type -- type of the ticked expression@@ -692,7 +691,7 @@  -- Convert the RHS of a binding from Core to STG. This is a wrapper around -- coreToStgExpr that can handle value lambdas.-coreToPreStgRhs :: CoreExpr -> CtsM PreStgRhs+coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr coreToPreStgRhs expr@(Lam _ _) =     let@@ -724,8 +723,8 @@   , -- Dynamic StgConApps are updatable     not (isDllConApp dflags this_mod con args)   = -- CorePrep does this right, but just to make sure-    ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)-           , ppr bndr $$ ppr con $$ ppr args)+    assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))+              (ppr bndr $$ ppr con $$ ppr args)     ( StgRhsCon dontCareCCS con mn ticks args, ccs )    -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].@@ -771,8 +770,10 @@    -- After this point we know that `bndrs` is empty,   -- so this is not a function binding-  | isJoinId bndr -- must be a nullary join point-  = ASSERT(idJoinArity bndr == 0)++  | isJoinId bndr -- Must be a nullary join point+  = -- It might have /type/ arguments (T18328),+    -- so its JoinArity might be >0     StgRhsClosure noExtFieldSilent                   currentCCS                   ReEntrant -- ignored for LNE@@ -927,7 +928,7 @@ lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of                         Just xx -> xx-                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound+                        Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound  getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) getAllCAFsCC this_mod =@@ -951,22 +952,22 @@     go bs (Cast e _)         = go bs e     go bs e                  = (reverse bs, e) --- | Precondition: argument expression is an 'App', and there is a 'Var' at the--- head of the 'App' chain.-myCollectArgs :: CoreExpr -> (Id, [CoreArg], [CoreTickish])+-- | If the argument expression is (potential chain of) 'App', return the head+-- of the app chain, and collect ticks/args along the chain.+myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish]) myCollectArgs expr   = go expr [] []   where-    go (Var v)          as ts = (v, as, ts)+    go h@(Var _v)       as ts = (h, as, ts)     go (App f a)        as ts = go f (a:as) ts-    go (Tick t e)       as ts = ASSERT2( not (tickishIsCode t) || all isTypeArg as-                                       , ppr e $$ ppr as $$ ppr ts )+    go (Tick t e)       as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as)+                                          (ppr e $$ ppr as $$ ppr ts) $                                 -- See Note [Ticks in applications]                                 go e as (t:ts) -- ticks can appear in type apps     go (Cast e _)       as ts = go e as ts     go (Lam b e)        as ts        | isTyVar b            = go e as ts -- Note [Collect args]-    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)+    go e                as ts = (e, as, ts)  {- Note [Collect args] ~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/CoreToStg/Prep.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE BangPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -17,8 +17,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -59,6 +57,7 @@ import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable import GHC.Utils.Monad  ( mapAccumLM ) import GHC.Utils.Logger@@ -164,32 +163,32 @@ ~~~~~~~~~~~~~~~~~~~~~~~ CorePrep does these two transformations: -* Convert empty case to cast with an unsafe coercion+1. Convert empty case to cast with an unsafe coercion           (case e of {}) ===>  e |> unsafe-co-  See Note [Empty case alternatives] in GHC.Core: if the case-  alternatives are empty, the scrutinee must diverge or raise an-  exception, so we can just dive into it.+   See Note [Empty case alternatives] in GHC.Core: if the case+   alternatives are empty, the scrutinee must diverge or raise an+   exception, so we can just dive into it. -  Of course, if the scrutinee *does* return, we may get a seg-fault.-  A belt-and-braces approach would be to persist empty-alternative-  cases to code generator, and put a return point anyway that calls a-  runtime system error function.+   Of course, if the scrutinee *does* return, we may get a seg-fault.+   A belt-and-braces approach would be to persist empty-alternative+   cases to code generator, and put a return point anyway that calls a+   runtime system error function. -  Notice that eliminating empty case can lead to an ill-kinded coercion-      case error @Int "foo" of {}  :: Int#-      ===> error @Int "foo" |> unsafe-co-      where unsafe-co :: Int ~ Int#-  But that's fine because the expression diverges anyway. And it's-  no different to what happened before.+   Notice that eliminating empty case can lead to an ill-kinded coercion+       case error @Int "foo" of {}  :: Int#+       ===> error @Int "foo" |> unsafe-co+       where unsafe-co :: Int ~ Int#+   But that's fine because the expression diverges anyway. And it's+   no different to what happened before. -* Eliminate unsafeEqualityProof in favour of an unsafe coercion-          case unsafeEqualityProof of UnsafeRefl g -> e-          ===>  e[unsafe-co/g]-  See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+2. Eliminate unsafeEqualityProof in favour of an unsafe coercion+           case unsafeEqualityProof of UnsafeRefl g -> e+           ===>  e[unsafe-co/g]+   See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce -  Note that this requiresuse ot substitute 'unsafe-co' for 'g', and-  that is the main (current) reason for cpe_tyco_env in CorePrepEnv.-  Tiresome, but not difficult.+   Note that this requires us to substitute 'unsafe-co' for 'g', and+   that is the main (current) reason for cpe_tyco_env in CorePrepEnv.+   Tiresome, but not difficult.  These transformations get rid of "case clutter", leaving only casts. We are doing no further significant tranformations, so the reasons@@ -197,7 +196,10 @@ the ANF-ery, CoreToStg, and backends, if trivial expressions really do look trivial. #19700 was an example. -In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 CorePrepProv).+In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 (CorePrepProv b)),+The boolean 'b' says whether the unsafe coercion is supposed to be+kind-homogeneous (yes for (2), no for (1).  This information is used+/only/ by Lint.  Note [CorePrep invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -287,7 +289,7 @@     go _   []             = return emptyFloats     go env (bind : binds) = do (env', floats, maybe_new_bind)                                  <- cpeBind TopLevel env bind-                               MASSERT(isNothing maybe_new_bind)+                               massert (isNothing maybe_new_bind)                                  -- Only join points get returned this way by                                  -- cpeBind, and no join point may float to top                                floatss <- go env' binds@@ -432,6 +434,150 @@ (Since f is not considered to be free in its own RHS.)  +Note [keepAlive# magic]+~~~~~~~~~~~~~~~~~~~~~~~+When interacting with foreign code, it is often necessary for the user to+extend the lifetime of a heap object beyond the lifetime that would be apparent+from the on-heap references alone. For instance, a program like:++  foreign import safe "hello" hello :: ByteArray# -> IO ()++  callForeign :: IO ()+  callForeign = IO $ \s0 ->+    case newByteArray# n# s0 of (# s1, barr #) ->+      unIO hello barr s1++As-written this program is susceptible to memory-unsafety since there are+no references to `barr` visible to the garbage collector. Consequently, if a+garbage collection happens during the execution of the C function `hello`, it+may be that the array is freed while in use by the foreign function.++To address this, we introduced a new primop, keepAlive#, which "scopes over"+the computation needing the kept-alive value:++  keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b).+                a -> State# RealWorld -> (State# RealWorld -> b) -> b++When entered, an application (keepAlive# x s k) will apply `k` to the state+token, evaluating it to WHNF. However, during the course of this evaluation+will *guarantee* that `x` is considered to be alive.++There are a few things to note here:++ - we are RuntimeRep-polymorphic in the value to be kept-alive. This is+   necessary since we will often (but not always) be keeping alive something+   unlifted (like a ByteArray#)++ - we are RuntimeRep-polymorphic in the result value since the result may take+   many forms (e.g. a boxed value, a raw state token, or a (# State s, result #).++We implement this operation by desugaring to touch# during CorePrep (see+GHC.CoreToStg.Prep.cpeApp). Specifically,++  keepAlive# x s0 k++is transformed to:++  case k s0 of r ->+  case touch# x realWorld# of s1 ->+    r++Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a+pointer to `x` and entering `k s0`. This compilation strategy is safe+because we do no optimization on STG that would drop or re-order the+continuation containing the `touch#`. However, if we were to become more+aggressive in our STG pipeline then we would need to revisit this.++Beyond this CorePrep transformation, there is very little special about+keepAlive#. However, we did explore (and eventually gave up on)+an optimisation which would allow unboxing of constructed product results,+which we describe below.+++Lost optimisation: CPR unboxing+--------------------------------+One unfortunate property of this approach is that the simplifier is unable to+unbox the result of a keepAlive# expression. For instance, consider the program:++  case keepAlive# arr s0 (+         \s1 -> case peekInt arr s1 of+                  (# s2, r #) -> I# r+  ) of+    I# x -> ...++This is a surprisingly common pattern, previously used, e.g., in+GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around+with optimising this away by pushing strict contexts (like the+`case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can+recover unboxing, it can also unfortunately in general change the asymptotic+memory (namely stack) behavior of the program. For instance, consider++  writeN =+    ...+      case keepAlive# x s0 (\s1 -> something s1) of+        (# s2, x #) ->+          writeN ...++As it is tail-recursive, this program will run in constant space. However, if+we push outer case into the continuation we get:++  writeN =++      case keepAlive# x s0 (\s1 ->+        case something s1 of+          (# s2, x #) ->+            writeN ...+      ) of+        ...++Which ends up building a stack which is linear in the recursion depth. For this+reason, we ended up giving up on this optimisation.+++Historical note: touch# and its inadequacy+------------------------------------------+Prior to the introduction of `keepAlive#` we instead addressed the need for+lifetime extension with the `touch#` primop:++    touch# :: a -> State# s -> State# s++This operation would ensure that the `a` value passed as the first argument was+considered "alive" at the time the primop application is entered.++For instance, the user might modify `callForeign` as:++  callForeign :: IO ()+  callForeign s0 = IO $ \s0 ->+    case newByteArray# n# s0 of (# s1, barr #) ->+    case unIO hello barr s1 of (# s2, () #) ->+    case touch# barr s2 of s3 ->+      (# s3, () #)++However, in #14346 we discovered that this primop is insufficient in the+presence of simplification. For instance, consider a program like:++  callForeign :: IO ()+  callForeign s0 = IO $ \s0 ->+    case newByteArray# n# s0 of (# s1, barr #) ->+    case unIO (forever $ hello barr) s1 of (# s2, () #) ->+    case touch# barr s2 of s3 ->+      (# s3, () #)++In this case the Simplifier may realize that (forever $ hello barr)+will never return and consequently that the `touch#` that follows is dead code.+As such, it will be dropped, resulting in memory unsoundness.+This unsoundness lead to the introduction of keepAlive#.++++Other related tickets:++ - #15544+ - #17760+ - #14375+ - #15260+ - #18061+ ************************************************************************ *                                                                      *                 The main code@@ -466,7 +612,7 @@        ; return (env2, floats1, Nothing) }    | otherwise -- A join point; see Note [Join points and floating]-  = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point+  = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point     do { (_, bndr1) <- cpCloneBndr env bndr        ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs        ; return (extendCorePrepEnv env bndr bndr2,@@ -511,7 +657,7 @@ -- Used for all bindings -- The binder is already cloned, hence an OutId cpePair top_lvl is_rec dmd is_unlifted env bndr rhs-  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair+  = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair     do { (floats1, rhs1) <- cpeRhsE env rhs         -- See if we are allowed to float this stuff out of the RHS@@ -521,7 +667,7 @@        ; (floats3, rhs3)             <- if manifestArity rhs1 <= arity                then return (floats2, cpeEtaExpand arity rhs2)-               else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)+               else warnPprTrace True (text "CorePrep: silly extra arguments:" <+> ppr bndr) $                                -- Note [Silly extra arguments]                     (do { v <- newVar (idType bndr)                         ; let float = mkFloat topDmd False v rhs2@@ -589,7 +735,7 @@ -- Used for all join bindings -- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils cpeJoinPair env bndr rhs-  = ASSERT(isJoinId bndr)+  = assert (isJoinId bndr) $     do { let Just join_arity = isJoinId_maybe bndr              (bndrs, body)   = collectNBinders join_arity rhs @@ -683,8 +829,14 @@ -- See Note [Unsafe coercions] cpeRhsE env (Case scrut _ ty [])   = do { (floats, scrut') <- cpeRhsE env scrut-       ; let ty' = cpSubstTy env ty-             co' = mkUnsafeCo Representational (exprType scrut') ty'+       ; let ty'       = cpSubstTy env ty+             scrut_ty' = exprType scrut'+             co'       = mkUnivCo prov Representational scrut_ty' ty'+             prov      = CorePrepProv False+               -- False says that the kinds of two types may differ+               -- E.g. we might cast Int to Int#.  This is fine+               -- because the scrutinee is guaranteed to diverge+        ; return (floats, Cast scrut' co') }    -- This can give rise to    --   Warning: Unsafe coercion: between unboxed and boxed value@@ -698,7 +850,8 @@                       -- is dead.  It usually is, but see #18227   , [Alt _ [co_var] rhs] <- alts   , let Pair ty1 ty2 = coVarTypes co_var-        the_co = mkUnsafeCo Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)+        the_co = mkUnivCo prov Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)+        prov   = CorePrepProv True  -- True <=> kind homogeneous         env'   = extendCoVarEnv env co_var the_co   = cpeRhsE env' rhs @@ -858,6 +1011,7 @@         = let (terminal, args', depth') = collect_args arg           in cpe_app env terminal (args' ++ args) (depth + depth' - 1) +    -- See Note [keepAlive# magic].     cpe_app env             (Var f)             args@@ -955,7 +1109,7 @@         -> [Demand]         -> UniqSM (CpeApp, Floats)     rebuild_app _ [] app floats ss-      = ASSERT(null ss) -- make sure we used all the strictness info+      = assert (null ss) -- make sure we used all the strictness info         return (app, floats)      rebuild_app env (a : as) fun' floats ss = case a of@@ -1156,7 +1310,15 @@ treatment for runRW# applications, ensure the arguments are not floated as MFEs. +Now that we float evaluation context into runRW#, we also have to give runRW# a+special higher-order CPR transformer lest we risk #19822. E.g., +  case runRW# (\s -> doThings) of x -> Data.Text.Text x something something'+      ~>+  runRW# (\s -> case doThings s of x -> Data.Text.Text x something something')++The former had the CPR property, and so should the latter.+ Other considered designs ------------------------ @@ -1211,9 +1373,6 @@ floating done by cpeArg. -} -mkUnsafeCo :: Role -> Type -> Type -> Coercion-mkUnsafeCo role ty1 ty2 = mkUnivCo CorePrepProv role ty1 ty2- -- | Is an argument okay to CPE? okCpeArg :: CoreExpr -> Bool -- Don't float literals. See Note [ANF-ising literal string arguments].@@ -1468,7 +1627,7 @@     -- Otherwise we get  case (\x -> e) of ...!    | is_unlifted = FloatCase rhs bndr DEFAULT [] True-      -- we used to ASSERT2(ok_for_spec, ppr rhs) here, but it is now disabled+      -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled       -- because exprOkForSpeculation isn't stable under ANF-ing. See for       -- example #19489 where the following unlifted expression:       --@@ -1949,7 +2108,7 @@         -- those early, as relying on mkTick to spot it after the fact         -- can yield O(n^3) complexity [#11095]         go (floats, ticks) (FloatTick t)-          = ASSERT(tickishPlace t == PlaceNonLam)+          = assert (tickishPlace t == PlaceNonLam)             (floats, if any (flip tickishContains t) ticks                      then ticks else t:ticks)         go (floats, ticks) f
compiler/GHC/Driver/Backpack.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-}@@ -17,8 +17,6 @@  module GHC.Driver.Backpack (doBackpack) where -#include "GhclibHsVersions.h"- import GHC.Prelude  -- In a separate module because it hooks into the parser.@@ -37,7 +35,6 @@ import GHC.Parser.Header import GHC.Parser.Lexer import GHC.Parser.Annotation-import GHC.Parser.Errors.Ppr  import GHC hiding (Failed, Succeeded) import GHC.Tc.Utils.Monad@@ -108,7 +105,7 @@     buf <- liftIO $ hGetStringBuffer src_filename     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great     case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of-        PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst))+        PFailed pst -> throwErrors (GhcPsMessage <$> getErrorMessages pst)         POk _ pkgname_bkp -> do             -- OK, so we have an LHsUnit PackageName, but we want an             -- LHsUnit HsComponentId.  So let's rename it.@@ -809,9 +806,8 @@                          Nothing -- GHC API buffer support not supported                          [] -- No exclusions          case r of-            Nothing -> throwOneError $ mkPlainErrorMsgEnvelope loc $-                                       GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $-                                       (text "module" <+> ppr modname <+> text "was not found")+            Nothing -> throwOneError $ fmap GhcDriverMessage+                                     $ mkPlainErrorMsgEnvelope loc (DriverBackpackModuleNotFound modname)             Just (Left err) -> throwErrors (fmap GhcDriverMessage err)             Just (Right summary) -> return summary
compiler/GHC/Driver/CodeOutput.hs view
@@ -4,8 +4,8 @@ \section{Code output phase} -} -{-# LANGUAGE CPP #-} + module GHC.Driver.CodeOutput    ( codeOutput    , outputForeignStubs@@ -14,8 +14,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang@@ -43,6 +41,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger+import GHC.Utils.Exception (bracket)  import GHC.Unit import GHC.Unit.State@@ -53,7 +52,6 @@ import GHC.Types.ForeignStubs import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) -import Control.Exception import System.Directory import System.FilePath import System.IO
compiler/GHC/Driver/Main.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+ {-# LANGUAGE NondecreasingIndentation #-}  {-# OPTIONS_GHC -fprof-auto-top #-}@@ -40,8 +40,7 @@      -- * Compiling complete source files     , Messager, batchMsg-    , HscStatus (..)-    , hscIncrementalCompile+    , HscBackendAction (..), HscRecompStatus (..)     , initModDetails     , hscMaybeWriteIface     , hscCompileCmmFile@@ -50,11 +49,14 @@     , hscInteractive      -- * Running passes separately+    , hscRecompStatus     , hscParse     , hscTypecheckRename+    , hscTypecheckAndGetWarnings     , hscDesugar     , makeSimpleDetails     , hscSimplify -- ToDo, shouldn't really export this+    , hscDesugarAndSimplify      -- * Safe Haskell     , hscCheckSafe@@ -143,8 +145,6 @@ import GHC.CoreToStg.Prep import GHC.CoreToStg    ( coreToStg ) -import GHC.Parser.Errors-import GHC.Parser.Errors.Ppr import GHC.Parser.Errors.Types import GHC.Parser import GHC.Parser.Lexer as Lexer@@ -198,7 +198,6 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Name-import GHC.Types.Name.Env import GHC.Types.Name.Cache ( initNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr@@ -207,6 +206,7 @@  import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc@@ -231,10 +231,7 @@ import Data.Set (Set) import Data.Functor import Control.DeepSeq (force)-import Data.Bifunctor (first, bimap)--#include "GhclibHsVersions.h"-+import Data.Bifunctor (first)  {- ********************************************************************** %*                                                                      *@@ -289,26 +286,21 @@  -- | log warning in the monad, and if there are errors then -- throw a SourceError exception.-logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc ()+logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc () logWarningsReportErrors (warnings,errors) = do-    dflags <- getDynFlags-    let warns = foldPsMessages (mkParserWarn dflags) warnings-        errs  = foldPsMessages mkParserErr           errors-    logDiagnostics warns-    when (not $ isEmptyMessages errs) $ throwErrors errs+    logDiagnostics (GhcPsMessage <$> warnings)+    when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors)  -- | Log warnings and throw errors, assuming the messages -- contain at least one error (e.g. coming from PFailed)-handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a+handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do     dflags <- getDynFlags-    let warns = foldPsMessages (mkParserWarn dflags) warnings-        errs  = foldPsMessages mkParserErr           errors-    logDiagnostics warns+    logDiagnostics (GhcPsMessage <$> warnings)     logger <- getLogger-    let (wWarns, wErrs) = partitionMessages warns+    let (wWarns, wErrs) = partitionMessages warnings     liftIO $ printMessages logger dflags wWarns-    throwErrors $ errs `unionMessages` wErrs+    throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs  -- | Deal with errors and warnings returned by a compilation step --@@ -333,7 +325,7 @@     logDiagnostics warns     case mb_r of         Nothing -> throwErrors errs-        Just r  -> ASSERT( isEmptyMessages errs ) return r+        Just r  -> assert (isEmptyMessages errs ) return r  -- | like ioMsgMaybe, except that we ignore error messages and return -- 'Nothing' instead.@@ -419,11 +411,8 @@         PFailed pst ->             handleWarningsThrowErrors (getMessages pst)         POk pst rdr_module -> do-            let (warns, errs) =-                  bimap (foldPsMessages (mkParserWarn dflags))-                        (foldPsMessages mkParserErr)-                        (getMessages pst)-            logDiagnostics warns+            let (warns, errs) = getMessages pst+            logDiagnostics (GhcPsMessage <$> warns)             liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"                         FormatHaskell (ppr rdr_module)             liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"@@ -432,7 +421,7 @@                                                    rdr_module)             liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics"                         FormatText (ppSourceStats False rdr_module)-            when (not $ isEmptyMessages errs) $ throwErrors errs+            when (not $ isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)              -- To get the list of extra source files, we take the list             -- that the parser gave us,@@ -520,6 +509,12 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $     hsc_typecheck True mod_summary (Just rdr_module) +-- | Do Typechecking without throwing SourceError exception with -Werror+hscTypecheckAndGetWarnings :: HscEnv ->  ModSummary -> IO (FrontendResult, WarningMessages)+hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do+  case hscFrontendHook (hsc_hooks hsc_env) of+    Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing+    Just h  -> h summary  -- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack -- b) concerning dumping rename info and hie files. It would be nice to further@@ -540,7 +535,7 @@         src_filename  = ms_hspp_file mod_summary         real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1         keep_rn' = gopt Opt_WriteHie dflags || keep_rn-    MASSERT( isHomeModule home_unit outer_mod )+    massert (isHomeModule home_unit outer_mod)     tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)         then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc         else@@ -572,7 +567,7 @@         logDiagnostics $ singleMessage $         mkPlainMsgEnvelope dflags (getLoc (hpm_module mod)) $         GhcDriverMessage $ DriverUnknownMessage $-        mkPlainDiagnostic reason warnMissingSafeHaskellMode+        mkPlainDiagnostic reason noHints warnMissingSafeHaskellMode      tcg_res <- {-# SCC "Typecheck-Rename" #-}                ioMsgMaybe $ hoistTcRnMessage $@@ -602,14 +597,14 @@                 | otherwise -> (logDiagnostics $ singleMessage $                        mkPlainMsgEnvelope dflags (warnSafeOnLoc dflags) $                        GhcDriverMessage $ DriverUnknownMessage $-                       mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) $+                       mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) noHints $                        errSafe tcg_res')               False | safeHaskell dflags == Sf_Trustworthy &&                       wopt Opt_WarnTrustworthySafe dflags ->                       (logDiagnostics $ singleMessage $                        mkPlainMsgEnvelope dflags (trustworthyOnLoc dflags) $                        GhcDriverMessage $ DriverUnknownMessage $-                       mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) $+                       mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) noHints $                        errTwthySafe tcg_res')               False -> return ()           return tcg_res'@@ -629,14 +624,9 @@ hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts hscDesugar' mod_location tc_result = do     hsc_env <- getHscEnv-    r <- ioMsgMaybe $ hoistDsMessage $-        {-# SCC "deSugar" #-}-        deSugar hsc_env mod_location tc_result--    -- always check -Werror after desugaring, this is the last opportunity for-    -- warnings to arise before the backend.-    handleWarnings-    return r+    ioMsgMaybe $ hoistDsMessage $+      {-# SCC "deSugar" #-}+      deSugar hsc_env mod_location tc_result  -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation.@@ -689,141 +679,42 @@  type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () --- | This function runs GHC's frontend with recompilation--- avoidance. Specifically, it checks if recompilation is needed,--- and if it is, it parses and typechecks the input module.--- It does not write out the results of typechecking (See--- compileOne and hscIncrementalCompile).-hscIncrementalFrontend :: Bool -- always do basic recompilation check?-                       -> Maybe TcGblEnv-                       -> Maybe Messager-                       -> ModSummary-                       -> SourceModified-                       -> Maybe ModIface  -- Old interface, if available-                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)-                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))--hscIncrementalFrontend-  always_do_basic_recompilation_check m_tc_result-  mHscMessage mod_summary source_modified mb_old_iface mod_index-    = do-    hsc_env <- getHscEnv--    let msg what = case mHscMessage of+-- | Do the recompilation avoidance checks for both one-shot and --make modes+hscRecompStatus :: Maybe Messager+                -> HscEnv+                -> ModSummary+                -> SourceModified+                -> Maybe ModIface+                -> (Int,Int)+                -> IO HscRecompStatus+hscRecompStatus+    mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index+  = do+    let+        msg what = case mHscMessage of           -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode           Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary))           Nothing -> return () -        skip iface = do-            liftIO $ msg UpToDate-            return $ Left iface--        compile mb_old_hash reason = do-            liftIO $ msg reason-            tc_result <- case hscFrontendHook (hsc_hooks hsc_env) of-              Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False mod_summary Nothing-              Just h  -> h mod_summary-            return $ Right (tc_result, mb_old_hash)--        stable = case source_modified of-                     SourceUnmodifiedAndStable -> True-                     _                         -> False--    case m_tc_result of-         Just tc_result-          | not always_do_basic_recompilation_check ->-             return $ Right (FrontendTypecheck tc_result, Nothing)-         _ -> do-            (recomp_reqd, mb_checked_iface)-                <- {-# SCC "checkOldIface" #-}-                   liftIO $ checkOldIface hsc_env mod_summary-                                source_modified mb_old_iface-            -- save the interface that comes back from checkOldIface.-            -- In one-shot mode we don't have the old iface until this-            -- point, when checkOldIface reads it from the disk.-            let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface--            case mb_checked_iface of-                Just iface | not (recompileRequired recomp_reqd) ->-                    -- If the module used TH splices when it was last-                    -- compiled, then the recompilation check is not-                    -- accurate enough (#481) and we must ignore-                    -- it.  However, if the module is stable (none of-                    -- the modules it depends on, directly or-                    -- indirectly, changed), then we *can* skip-                    -- recompilation. This is why the SourceModified-                    -- type contains SourceUnmodifiedAndStable, and-                    -- it's pretty important: otherwise ghc --make-                    -- would always recompile TH modules, even if-                    -- nothing at all has changed. Stability is just-                    -- the same check that make is doing for us in-                    -- one-shot mode.-                    case m_tc_result of-                    Nothing-                     | mi_used_th iface && not stable ->-                        compile mb_old_hash (RecompBecause "TH")-                    _ ->-                        skip iface-                _ ->-                    case m_tc_result of-                    Nothing -> compile mb_old_hash recomp_reqd-                    Just tc_result ->-                        return $ Right (FrontendTypecheck tc_result, mb_old_hash)------------------------------------------------------------------- Compilers------------------------------------------------------------------- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts--- of the pipeline.--- We return a interface if we already had an old one around and recompilation--- was not needed. Otherwise it will be created during later passes when we--- run the compilation pipeline.-hscIncrementalCompile :: Bool-                      -> Maybe TcGblEnv-                      -> Maybe Messager-                      -> HscEnv-                      -> ModSummary-                      -> SourceModified-                      -> Maybe ModIface-                      -> (Int,Int)-                      -> IO (HscStatus, HscEnv)-hscIncrementalCompile always_do_basic_recompilation_check m_tc_result-    mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index-  = do-    hsc_env'' <- initializePlugins hsc_env'+    (recomp_reqd, mb_checked_iface)+        <- {-# SCC "checkOldIface" #-}+           liftIO $ checkOldIface hsc_env mod_summary+                        source_modified mb_old_iface -    -- One-shot mode needs a knot-tying mutable variable for interface-    -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.-    -- See also Note [hsc_type_env_var hack]-    type_env_var <- newIORef emptyNameEnv-    let mod = ms_mod mod_summary-        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))-                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }-                | otherwise-                = hsc_env''+    -- save the interface that comes back from checkOldIface.+    -- In one-shot mode we don't have the old iface until this+    -- point, when checkOldIface reads it from the disk.+    let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface -    -- NB: enter Hsc monad here so that we don't bail out early with-    -- -Werror on typechecker warnings; we also want to run the desugarer-    -- to get those warnings too. (But we'll always exit at that point-    -- because the desugarer runs ioMsgMaybe.)-    runHsc hsc_env $ do-    e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage-            mod_summary source_modified mb_old_iface mod_index-    case e of+    msg recomp_reqd+    case mb_checked_iface of+      Just iface | not (recompileRequired recomp_reqd) -> do         -- We didn't need to do any typechecking; the old interface         -- file on disk was good enough.-        Left iface -> do-            details <- liftIO $ initModDetails hsc_env mod_summary iface-            return (HscUpToDate iface details, hsc_env')-        -- We finished type checking.  (mb_old_hash is the hash of-        -- the interface that existed on disk; it's possible we had-        -- to retypecheck but the resulting interface is exactly-        -- the same.)-        Right (FrontendTypecheck tc_result, mb_old_hash) -> do-            status <- finish mod_summary tc_result mb_old_hash-            return (status, hsc_env)+        return $ HscUpToDate iface +      _ -> return $ HscRecompNeeded mb_old_hash+ -- Knot tying!  See Note [Knot-tying typecheckIface] -- See Note [ModDetails and --make mode] initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails@@ -894,11 +785,12 @@ -- HscRecomp in turn will carry the information required to compute a interface -- when passed the result of the code generator. So all this can and is done at -- the call site of the backend code gen if it is run.-finish :: ModSummary-       -> TcGblEnv+hscDesugarAndSimplify :: ModSummary+       -> FrontendResult+       -> Messages GhcMessage        -> Maybe Fingerprint-       -> Hsc HscStatus-finish summary tc_result mb_old_hash = do+       -> Hsc HscBackendAction+hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do   hsc_env <- getHscEnv   dflags <- getDynFlags   logger <- getLogger@@ -916,6 +808,11 @@       then Just <$> hscDesugar' (ms_location summary) tc_result       else pure Nothing +  -- Report the warnings from both typechecking and desugar together+  w <- getDiagnostics+  liftIO $ printOrThrowDiagnostics logger dflags (unionMessages tc_warnings w)+  clearDiagnostics+   -- Simplify, if appropriate, and (whether we simplified or not) generate an   -- interface file.   case mb_desugar of@@ -942,17 +839,12 @@       -- We are not generating code, so we can skip simplification       -- and generate a simple interface.       _ -> do-        (iface, mb_old_iface_hash, details) <- liftIO $+        (iface, mb_old_iface_hash, _details) <- liftIO $           hscSimpleIface hsc_env tc_result mb_old_hash          liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary) -        return $ case bcknd of-          NoBackend -> HscNotGeneratingCode iface details-          _         -> case hsc_src of-                        HsBootFile -> HscUpdateBoot iface details-                        HsigFile   -> HscUpdateSig iface details-                        _          -> panic "finish"+        return $ HscUpdate iface  {- Note [Writing interface files]@@ -977,7 +869,7 @@  Cases for which we generate simple interfaces: -   * GHC.Driver.Main.finish: when a compilation does NOT require (re)compilation+   * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation    of the hard code     * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target@@ -1203,7 +1095,7 @@     warnRules df (L loc (HsRule { rd_name = n })) =         mkPlainMsgEnvelope df (locA loc) $         DriverUnknownMessage $-        mkPlainDiagnostic WarningWithoutFlag $+        mkPlainDiagnostic WarningWithoutFlag noHints $             text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$             text "User defined rules are disabled under Safe Haskell" @@ -1281,7 +1173,7 @@         | imv_is_safe v1 /= imv_is_safe v2         = throwOneError $             mkPlainErrorMsgEnvelope (imv_span v1) $-            GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $+            GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $               text "Module" <+> ppr (imv_name v1) <+>                (text $ "is imported both as a safe and unsafe import!")         | otherwise@@ -1351,7 +1243,7 @@             -- can't load iface to check trust!             Nothing -> throwOneError $                          mkPlainErrorMsgEnvelope l $-                         GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $+                         GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $                            text "Can't load the interface file for" <+> ppr m                              <> text ", to check that it can be safely imported" @@ -1364,7 +1256,7 @@                     -- check package is trusted                     safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m                     -- pkg trust reqs-                    pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'+                    pkgRs = S.fromList (dep_trusted_pkgs $ mi_deps iface')                     -- warn if Safe module imports Safe-Inferred module.                     warns = if wopt Opt_WarnInferredSafeImports dflags                                 && safeLanguageOn dflags@@ -1386,7 +1278,7 @@                     inferredImportWarn dflags = singleMessage                         $ mkMsgEnvelope dflags l (pkgQual state)                         $ GhcDriverMessage $ DriverUnknownMessage-                        $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports)+                        $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports) noHints                         $ sep                             [ text "Importing Safe-Inferred module "                                 <> ppr (moduleName m)@@ -1395,7 +1287,7 @@                     pkgTrustErr = singleMessage                       $ mkErrorMsgEnvelope l (pkgQual state)                       $ GhcDriverMessage $ DriverUnknownMessage-                      $ mkPlainError+                      $ mkPlainError noHints                       $ sep [ ppr (moduleName m)                                 <> text ": Can't be safely imported!"                             , text "The package ("@@ -1405,7 +1297,7 @@                     modTrustErr = singleMessage                       $ mkErrorMsgEnvelope l (pkgQual state)                       $ GhcDriverMessage $ DriverUnknownMessage-                      $ mkPlainError+                      $ mkPlainError noHints                       $ sep [ ppr (moduleName m)                                 <> text ": Can't be safely imported!"                             , text "The module itself isn't safe." ]@@ -1455,7 +1347,7 @@                      $ mkErrorMsgEnvelope noSrcSpan (pkgQual state)                      $ GhcDriverMessage                      $ DriverUnknownMessage-                     $ mkPlainError+                     $ mkPlainError noHints                      $ pprWithUnitState state                      $ text "The package ("                         <> ppr pkg@@ -1483,7 +1375,7 @@          (logDiagnostics $ singleMessage $              mkPlainMsgEnvelope dflags (warnUnsafeOnLoc dflags) $              GhcDriverMessage $ DriverUnknownMessage $-             mkPlainDiagnostic reason $+             mkPlainDiagnostic reason noHints $              whyUnsafe' dflags)      liftIO $ writeIORef (tcg_safe_infer tcg_env) False@@ -1520,7 +1412,6 @@                       text "overlap mode isn't allowed in Safe Haskell"]                 | otherwise = [] - -- | Figure out the final correct safe haskell mode hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode hscGetSafeMode tcg_env = do@@ -1717,10 +1608,8 @@                $ do                   (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())                                        $ parseCmmFile dflags cmm_mod home_unit filename-                  let msgs = foldPsMessages (mkParserWarn dflags) warns-                             `unionMessages`-                             foldPsMessages mkParserErr errs-                  return (msgs, cmm)+                  let msgs = warns `unionMessages` errs+                  return (GhcPsMessage <$> msgs, cmm)     liftIO $ do         dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) @@ -2082,7 +1971,7 @@         [L _ i] -> return i         _ -> liftIO $ throwOneError $                  mkPlainErrorMsgEnvelope noSrcSpan $-                 GhcPsMessage $ PsUnknownMessage $ mkPlainError $+                 GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $                      text "parse error in import declaration"  -- | Typecheck an expression (but don't run it)@@ -2113,7 +2002,7 @@     Just (L _ (BodyStmt _ expr _ _)) -> return expr     _ -> throwOneError $            mkPlainErrorMsgEnvelope noSrcSpan $-           GhcPsMessage $ PsUnknownMessage $ mkPlainError $+           GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $              text "not an expression:" <+> quotes (text expr)  hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
compiler/GHC/Driver/Make.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-}@@ -29,6 +28,7 @@         ms_home_srcimps, ms_home_imps,          summariseModule,+        summariseFile,         hscSourceToIsBoot,         findExtraSigImports,         implicitRequirementsShallow,@@ -40,8 +40,6 @@         ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Tc.Utils.Backpack@@ -77,14 +75,16 @@ import GHC.Data.StringBuffer import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.Exception ( tryIO )+import GHC.Utils.Exception ( tryIO, AsyncException(..), evaluate ) import GHC.Utils.Monad     ( allM ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.TmpFs+import GHC.Utils.Constants (isWindowsHost)  import GHC.Types.Basic import GHC.Types.Error@@ -118,7 +118,6 @@ import qualified GHC.Conc as CC import Control.Concurrent.MVar import Control.Concurrent.QSem-import Control.Exception import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC@@ -271,7 +270,7 @@ warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () warnMissingHomeModules hsc_env mod_graph =     when (not (null missing)) $-        logDiagnostics warn+        logDiagnostics (GhcDriverMessage <$> warn)   where     dflags = hsc_dflags hsc_env     targets = map targetId (hsc_targets hsc_env)@@ -306,22 +305,8 @@     missing = map (moduleName . ms_mod) $       filter (not . is_known_module) (mgModSummaries mod_graph) -    msg-      | gopt Opt_BuildingCabalPackage dflags-      = hang-          (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")-          4-          (sep (map ppr missing))-      | otherwise-      =-        hang-          (text "Modules are not listed in command line but needed for compilation: ")-          4-          (sep (map ppr missing))-    warn = singleMessage $-      mkPlainMsgEnvelope (hsc_dflags hsc_env) noSrcSpan $-      GhcDriverMessage $ DriverUnknownMessage $-      mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingHomeModules) msg+    warn = singleMessage $ mkPlainMsgEnvelope (hsc_dflags hsc_env) noSrcSpan+                         $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)  -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch@@ -386,27 +371,15 @@           = filter (\arg -> not $ any (matching state arg) loadedPackages)                    requestedArgs -    let warn = singleMessage $-          mkPlainMsgEnvelope dflags noSrcSpan $-          GhcDriverMessage $ DriverUnknownMessage $-          mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedPackages) msg-        msg = vcat [ text "The following packages were specified" <+>-                     text "via -package or -package-id flags,"-                   , text "but were not needed for compilation:"-                   , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ]+    let warn = singleMessage $ mkPlainMsgEnvelope dflags noSrcSpan (DriverUnusedPackages unusedArgs)      when (not (null unusedArgs)) $-      logDiagnostics warn+      logDiagnostics (GhcDriverMessage <$> warn)      where         packageArg (ExposePackage _ arg _) = Just arg         packageArg _ = Nothing -        pprUnusedArg (PackageArg str) = text str-        pprUnusedArg (UnitIdArg uid) = ppr uid--        withDash = (<+>) (text "-")-         matchingStr :: String -> UnitInfo -> Bool         matchingStr str p                 =  str == unitPackageIdString p@@ -451,7 +424,7 @@     -- files without corresponding hs files.     --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,     --                              not (ms_mod_name s `elem` all_home_mods)]-    -- ASSERT( null bad_boot_mods ) return ()+    -- assert (null bad_boot_mods ) return ()      -- check that the module given in HowMuch actually exists, otherwise     -- topSortModuleGraph will bomb later.@@ -545,8 +518,9 @@         -- is stable).         partial_mg             | LoadDependenciesOf _mod <- how_much-            = ASSERT( case last partial_mg0 of-                        AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod; _ -> False )+            = assert (case last partial_mg0 of+                        AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod+                        _ -> False) $               List.init partial_mg0             | otherwise             = partial_mg0@@ -684,7 +658,7 @@                  || allHpt (isJust.hm_linkable)                         (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)                                 hpt5)-          ASSERT( just_linkables ) do+          assert just_linkables $ do            -- Link everything together           hsc_env <- getSession@@ -769,14 +743,12 @@         name = fmap dropExtension mainModuleSrcPath          name_exe = do-#if defined(mingw32_HOST_OS)           -- we must add the .exe extension unconditionally here, otherwise           -- when name has an extension of its own, the .exe extension will           -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248-          name' <- fmap (<.> "exe") name-#else-          name' <- name-#endif+          name' <- if isWindowsHost --FIXME: should be the target platform+                    then fmap (<.> "exe") name+                    else name           mainModuleSrcPath' <- mainModuleSrcPath           -- #9930: don't clobber input files (unless they ask for it)           if name' == mainModuleSrcPath'@@ -1542,7 +1514,7 @@     when (not $ null dropped_ms) $ do         dflags <- getSessionDynFlags         logger <- getLogger-        liftIO $ fatalErrorMsg logger dflags (keepGoingPruneErr $ dropped_ms)+        liftIO $ debugTraceMsg logger dflags 2 (keepGoingPruneErr dropped_ms)     (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods'     return (Failed, done') @@ -1791,7 +1763,7 @@            | not (backendProducesObject bcknd), is_stable_bco,             (bcknd /= NoBackend) `implies` not is_fake_linkable ->-                ASSERT(isJust old_hmi) -- must be in the old_hpt+                assert (isJust old_hmi) $ -- must be in the old_hpt                 let Just hmi = old_hmi in do                 debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name)                 return hmi@@ -2226,10 +2198,7 @@          warn :: DynFlags -> Located ModuleName -> MsgEnvelope GhcMessage         warn dflags (L loc mod) =-           mkPlainMsgEnvelope dflags loc $-           GhcDriverMessage $ DriverUnknownMessage $-           mkPlainDiagnostic WarningWithoutFlag $-           text "{-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)+          GhcDriverMessage <$> mkPlainMsgEnvelope dflags loc (DriverUnnecessarySourceImports mod)   -----------------------------------------------------------------------------@@ -2300,10 +2269,8 @@                 if exists || isJust maybe_buf                     then summariseFile hsc_env old_summaries file mb_phase                                        obj_allowed maybe_buf-                    else return $ Left $ singleMessage $-                           mkPlainErrorMsgEnvelope noSrcSpan $-                           DriverUnknownMessage $ mkPlainError $-                             text "can't find file:" <+> text file+                    else return $ Left $ singleMessage+                                $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound file)         getRootSummary Target { targetId = TargetModule modl                               , targetAllowObjCode = obj_allowed                               , targetContents = maybe_buf@@ -2441,7 +2408,11 @@         let ms' = ms               { ms_location =                   ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}-              , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd}+              , ms_hspp_opts = updOptLevel 0 $+                  setOutputFile (Just o_file) $+                  setDynOutputFile (Just $ dynamicOutputFile dflags o_file) $+                  setOutputHi (Just hi_file) $+                  dflags {backend = bcknd}               }         pure (ExtendedModSummary ms' bkp_deps)       | otherwise = return (ExtendedModSummary ms bkp_deps)@@ -2737,32 +2708,13 @@               | otherwise = HsSrcFile          when (pi_mod_name /= wanted_mod) $-                throwE $ singleMessage $-                  mkPlainErrorMsgEnvelope pi_mod_name_loc $-                  DriverUnknownMessage $ mkPlainError $-                              text "File name does not match module name:"-                              $$ text "Saw:" <+> quotes (ppr pi_mod_name)-                              $$ text "Expected:" <+> quotes (ppr wanted_mod)+                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                       $ DriverFileModuleNameMismatch pi_mod_name wanted_mod          when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $-            let suggested_instantiated_with =-                    hcat (punctuate comma $-                        [ ppr k <> text "=" <> ppr v-                        | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)-                                : homeUnitInstantiations home_unit)-                        ])-            in throwE $ singleMessage $-                mkPlainErrorMsgEnvelope pi_mod_name_loc $-                DriverUnknownMessage $ mkPlainError $-                text "Unexpected signature:" <+> quotes (ppr pi_mod_name)-                $$ if gopt Opt_BuildingCabalPackage dflags-                    then parens (text "Try adding" <+> quotes (ppr pi_mod_name)-                            <+> text "to the"-                            <+> quotes (text "signatures")-                            <+> text "field in your Cabal file.")-                    else parens (text "Try passing -instantiated-with=\"" <>-                                 suggested_instantiated_with <> text "\"" $$-                                text "replacing <" <> ppr pi_mod_name <> text "> as necessary.")+            let instantiations = homeUnitInstantiations home_unit+            in throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                      $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations          liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary             { nms_src_fn = src_fn@@ -2866,7 +2818,7 @@           let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags               popts = initParserOpts pi_local_dflags           mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn-          return (first (mkMessages . fmap mkDriverPsHeaderMessage) mimps)+          return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)   return PreprocessedImports {..}  @@ -2913,30 +2865,22 @@ noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err-  = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $+  = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $     cannotFindModule hsc_env wanted_mod err  noHsFileErr :: SrcSpan -> String -> DriverMessages noHsFileErr loc path-  = singleMessage $ mkPlainErrorMsgEnvelope loc $-    DriverUnknownMessage $ mkPlainError $-    text "Can't find" <+> text path+  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)  moduleNotFoundErr :: ModuleName -> DriverMessages moduleNotFoundErr mod-  = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan $-    DriverUnknownMessage $ mkPlainError $-        text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"+  = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)  multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_)-  = throwOneError $-      mkPlainErrorMsgEnvelope noSrcSpan $-      GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $-        text "module" <+> quotes (ppr mod) <+>-        text "is defined in multiple files:" <+>-        sep (map text files)+  = throwOneError $ fmap GhcDriverMessage $+    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files   where     mod = ms_mod summ1     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs@@ -2951,7 +2895,7 @@ -- From a strongly connected component we find -- a single cycle to report cyclicModuleErr mss-  = ASSERT( not (null mss) )+  = assert (not (null mss)) $     case findCycle graph of        Nothing   -> text "Unexpected non-cycle" <+> ppr mss        Just path0 -> vcat
compiler/GHC/Driver/MakeFile.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Makefile Dependency Generation@@ -13,8 +13,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import qualified GHC@@ -28,6 +26,7 @@ import GHC.Data.Graph.Directed ( SCC(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SourceError import GHC.Types.SrcLoc import Data.List (partition)@@ -308,7 +307,7 @@     fail ->         throwOneError $           mkPlainErrorMsgEnvelope srcloc $-          GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $+          GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $              cannotFindModule hsc_env imp fail  -----------------------------@@ -360,27 +359,20 @@   case makefile_hdl of      Nothing  -> return ()      Just hdl -> do--          -- slurp the rest of the original makefile and copy it into the output-        let slurp = do-                l <- hGetLine hdl-                hPutStrLn tmp_hdl l-                slurp--        catchIO slurp-                (\e -> if isEOFError e then return () else ioError e)-+        -- slurp the rest of the original makefile and copy it into the output+        SysTools.copyHandle hdl tmp_hdl         hClose hdl    hClose tmp_hdl  -- make sure it's flushed          -- Create a backup of the original makefile-  when (isJust makefile_hdl)-       (SysTools.copy logger dflags ("Backing up " ++ makefile)-          makefile (makefile++".bak"))+  when (isJust makefile_hdl) $ do+    showPass logger dflags ("Backing up " ++ makefile)+    SysTools.copyFile makefile (makefile++".bak")          -- Copy the new makefile in place-  SysTools.copy logger dflags "Installing new makefile" tmp_file makefile+  showPass logger dflags "Installing new makefile"+  SysTools.copyFile tmp_file makefile   -----------------------------------------------------------------@@ -418,7 +410,7 @@      pp_group (AcyclicSCC ms) = pp_ms ms     pp_group (CyclicSCC mss)-        = ASSERT( not (null boot_only) )+        = assert (not (null boot_only)) $                 -- The boot-only list must be non-empty, else there would                 -- be an infinite chain of non-boot imports, and we've                 -- already checked for that in processModDeps
compiler/GHC/Driver/Pipeline.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-}@@ -35,9 +36,7 @@    linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode   ) where -#include <ghcplatform.h>-#include "GhclibHsVersions.h"-+#include "ghcplatform.h" import GHC.Prelude  import GHC.Platform@@ -60,7 +59,6 @@ import GHC.Platform.ArchOS  import GHC.Parser.Header-import GHC.Parser.Errors.Ppr  import GHC.SysTools import GHC.Utils.TmpFs@@ -72,7 +70,9 @@  import GHC.Utils.Outputable import GHC.Utils.Error+import GHC.Utils.Fingerprint import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Exception as Exception@@ -87,9 +87,11 @@ import GHC.Data.Maybe          ( expectJust )  import GHC.Iface.Make          ( mkFullIface )+import GHC.Runtime.Loader      ( initializePlugins )  import GHC.Types.Basic       ( SuccessFlag(..) ) import GHC.Types.Error       ( singleMessage, getMessages )+import GHC.Types.Name.Env import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile@@ -110,6 +112,7 @@ import System.IO import Control.Monad import qualified Control.Monad.Catch as MC (handle)+import Data.IORef import Data.List        ( isInfixOf, intercalate ) import Data.Maybe import Data.Version@@ -136,8 +139,8 @@   handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $   MC.handle handler $   fmap Right $ do-  MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)-  (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)+  massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn)+  (dflags, fp, mb_iface, mb_linkable) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)         Nothing         -- We keep the processed file for the whole session to save on         -- duplicated work in ghci.@@ -145,14 +148,15 @@         Nothing{-no ModLocation-}         []{-no foreign objects-}   -- We stop before Hsc phase so we shouldn't generate an interface-  MASSERT(isNothing mb_iface)+  massert (isNothing mb_iface)+  massert (isNothing mb_linkable)   return (dflags, fp)   where     srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1     handler (ProgramError msg) =       return $ Left $ singleMessage $         mkPlainErrorMsgEnvelope srcspan $-        DriverUnknownMessage $ mkPlainError $ text msg+        DriverUnknownMessage $ mkPlainError noHints $ text msg     handler ex = throwGhcExceptionIO ex      to_driver_messages :: Messages GhcMessage -> Messages DriverMessage@@ -205,18 +209,8 @@             source_modified0  = do -   let logger = hsc_logger hsc_env0-   let tmpfs  = hsc_tmpfs hsc_env0    debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp) -   -- Run the pipeline up to codeGen (so everything up to, but not including, STG)-   (status, plugin_hsc_env) <- hscIncrementalCompile-                        always_do_basic_recompilation_check-                        m_tc_result mHscMessage-                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)-   -- Use an HscEnv updated with the plugin info-   let hsc_env' = plugin_hsc_env-    let flags = hsc_dflags hsc_env0      in do unless (gopt Opt_KeepHiFiles flags) $                addFilesToClean tmpfs TFL_CurrentModule $@@ -225,101 +219,29 @@                addFilesToClean tmpfs TFL_GhcSession $                    [ml_obj_file $ ms_location summary] -   case (status, bcknd) of-        (HscUpToDate iface hmi_details, _) ->-            -- TODO recomp014 triggers this assert. What's going on?!-            -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )-            return $! HomeModInfo iface hmi_details mb_old_linkable-        (HscNotGeneratingCode iface hmi_details, NoBackend) ->-            let mb_linkable = if isHsBootOrSig src_flavour-                                then Nothing-                                -- TODO: Questionable.-                                else Just (LM (ms_hs_date summary) this_mod [])-            in return $! HomeModInfo iface hmi_details mb_linkable-        (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode"-        (_, NoBackend) -> panic "compileOne NoBackend"-        (HscUpdateBoot iface hmi_details, Interpreter) ->-            return $! HomeModInfo iface hmi_details Nothing-        (HscUpdateBoot iface hmi_details, _) -> do-            touchObjectFile logger dflags object_filename-            return $! HomeModInfo iface hmi_details Nothing-        (HscUpdateSig iface hmi_details, Interpreter) -> do-            let !linkable = LM (ms_hs_date summary) this_mod []-            return $! HomeModInfo iface hmi_details (Just linkable)-        (HscUpdateSig iface hmi_details, _) -> do-            output_fn <- getOutputFilename logger tmpfs next_phase-                            (Temporary TFL_CurrentModule) basename dflags-                            next_phase (Just location)--            -- #10660: Use the pipeline instead of calling-            -- compileEmptyStub directly, so -dynamic-too gets-            -- handled properly-            _ <- runPipeline StopLn hsc_env'-                              (output_fn,-                               Nothing,-                               Just (HscOut src_flavour-                                            mod_name (HscUpdateSig iface hmi_details)))-                              (Just basename)-                              Persistent-                              (Just location)-                              []-            o_time <- getModificationUTCTime object_filename-            let !linkable = LM o_time this_mod [DotO object_filename]-            return $! HomeModInfo iface hmi_details (Just linkable)-        (HscRecomp { hscs_guts = cgguts,-                     hscs_mod_location = mod_location,-                     hscs_partial_iface = partial_iface,-                     hscs_old_iface_hash = mb_old_iface_hash-                   }, Interpreter) -> do-            -- In interpreted mode the regular codeGen backend is not run so we-            -- generate a interface without codeGen info.-            final_iface <- mkFullIface hsc_env' partial_iface Nothing-            -- Reconstruct the `ModDetails` from the just-constructed `ModIface`-            -- See Note [ModDetails and --make mode]-            hmi_details <- liftIO $ initModDetails hsc_env' summary final_iface-            liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash (ms_location summary)+   plugin_hsc_env <- initializePlugins hsc_env -            (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location+   let runPostTc = compileOnePostTc plugin_hsc_env summary -            stub_o <- case hasStub of-                      Nothing -> return []-                      Just stub_c -> do-                          stub_o <- compileStub hsc_env' stub_c-                          return [DotO stub_o]+   case m_tc_result of+     Just tc_result+       | not always_do_basic_recompilation_check -> do+         runPostTc (FrontendTypecheck tc_result) emptyMessages Nothing+     _ -> do+       status <- hscRecompStatus mHscMessage plugin_hsc_env summary+            source_modified mb_old_iface (mod_index, nmods) -            let hs_unlinked = [BCOs comp_bc spt_entries]-                unlinked_time = ms_hs_date summary-              -- Why do we use the timestamp of the source file here,-              -- rather than the current time?  This works better in-              -- the case where the local clock is out of sync-              -- with the filesystem's clock.  It's just as accurate:-              -- if the source is modified, then the linkable will-              -- be out of date.-            let !linkable = LM unlinked_time (ms_mod summary)-                           (hs_unlinked ++ stub_o)-            return $! HomeModInfo final_iface hmi_details (Just linkable)-        (HscRecomp{}, _) -> do-            output_fn <- getOutputFilename logger tmpfs next_phase-                            (Temporary TFL_CurrentModule)-                            basename dflags next_phase (Just location)-            -- We're in --make mode: finish the compilation pipeline.-            (_, _, Just iface) <- runPipeline StopLn hsc_env'-                              (output_fn,-                               Nothing,-                               Just (HscOut src_flavour mod_name status))-                              (Just basename)-                              Persistent-                              (Just location)-                              []-                  -- The object filename comes from the ModLocation-            o_time <- getModificationUTCTime object_filename-            let !linkable = LM o_time this_mod [DotO object_filename]-            -- See Note [ModDetails and --make mode]-            details <- initModDetails hsc_env' summary iface-            return $! HomeModInfo iface details (Just linkable)+       case status of+         HscUpToDate iface -> do+           massert ( isJust mb_old_linkable || isNoLink (ghcLink dflags) )+           -- See Note [ModDetails and --make mode]+           details <- initModDetails plugin_hsc_env summary iface+           return $! HomeModInfo iface details mb_old_linkable+         HscRecompNeeded mb_old_hash -> do+           (tc_result, warnings) <- hscTypecheckAndGetWarnings plugin_hsc_env summary+           runPostTc tc_result warnings mb_old_hash   where dflags0     = ms_hspp_opts summary-       this_mod    = ms_mod summary        location    = ms_location summary        input_fn    = expectJust "compile:hs" (ml_hs_file location)        input_fnpp  = ms_hspp_file summary@@ -329,10 +251,8 @@        isProfWay   = any (== WayProf) (ways dflags0)        internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0) -       src_flavour = ms_hsc_src summary-       mod_name = ms_mod_name summary-       next_phase = hscPostBackendPhase src_flavour bcknd-       object_filename = ml_obj_file location+       logger = hsc_logger hsc_env0+       tmpfs  = hsc_tmpfs hsc_env0         -- #8180 - when using TemplateHaskell, switch on -dynamic-too so        -- the linker can correctly load the object files.  This isn't necessary@@ -371,7 +291,7 @@          = (Interpreter, dflags2 { backend = Interpreter })          | otherwise          = (backend dflags, dflags2)-       dflags  = dflags3 { includePaths = addQuoteInclude old_paths [current_dir] }+       dflags  = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] }        hsc_env = hsc_env0 {hsc_dflags = dflags}         -- -fforce-recomp should also work with --make@@ -387,6 +307,59 @@                                              Interpreter -> True                                              _ -> False +-- | Do the post typechecking compilation of a module in the --make mode+compileOnePostTc+  :: HscEnv+  -> ModSummary+  -> FrontendResult+  -> WarningMessages+  -> Maybe Fingerprint+  -> IO HomeModInfo+compileOnePostTc hsc_env summary tc_result warnings mb_old_hash = do+  output_fn <- getOutputFilename logger tmpfs next_phase+                  (Temporary TFL_CurrentModule)+                  basename dflags next_phase (Just location)+  (_, _, Just iface, mb_linkable) <- runPipeline StopLn hsc_env+                    (output_fn,+                     Nothing,+                     Just (HscPostTc summary tc_result warnings mb_old_hash))+                    (Just basename)+                    pipelineOutput+                    (Just location)+                    []+  -- TODO: figure out a way to set this in runPipeline for HsSrcFile+  mLinkable <- case () of+    _ | Just l <- mb_linkable -> return $ Just l+      | bcknd == NoBackend -> return Nothing+      | src_flavour == HsSrcFile -> do+        -- The object filename comes from the ModLocation+        o_time <- getModificationUTCTime object_filename+        let !linkable = LM o_time this_mod [DotO object_filename]+        return $ Just linkable+      | otherwise -> return Nothing+  -- See Note [ModDetails and --make mode]+  details <- initModDetails hsc_env summary iface+  return $! HomeModInfo iface details mLinkable++ where dflags      = hsc_dflags hsc_env+       this_mod    = ms_mod summary+       location    = ms_location summary+       input_fn    = expectJust "compile:hs" (ml_hs_file location)++       logger = hsc_logger hsc_env+       tmpfs  = hsc_tmpfs hsc_env+       src_flavour = ms_hsc_src summary+       next_phase = hscPostBackendPhase src_flavour bcknd+       bcknd = backend dflags+       object_filename = ml_obj_file location++       basename = dropExtension input_fn++       pipelineOutput = case bcknd of+         Interpreter -> NoOutputFile+         NoBackend -> NoOutputFile+         _ -> Persistent+ ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support), and cc files. @@ -413,7 +386,7 @@ #if __GLASGOW_HASKELL__ < 811               RawObject  -> panic "compileForeign: should be unreachable" #endif-        (_, stub_o, _) <- runPipeline StopLn hsc_env+        (_, stub_o, _, _) <- runPipeline StopLn hsc_env                        (stub_c, Nothing, Just (RealPhase phase))                        Nothing (Temporary TFL_GhcSession)                        Nothing{-no ModLocation-}@@ -554,7 +527,7 @@             home_mod_infos = eltsHpt hpt              -- the packages we depend on-            pkg_deps  = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos+            pkg_deps  = concatMap (dep_direct_pkgs . mi_deps . hm_iface) home_mod_infos              -- the linkables to link             linkables = map (expectJust "link".hm_linkable) home_mod_infos@@ -668,17 +641,14 @@         -- When linking, the -o argument refers to the linker's output.         -- otherwise, we use it as the name for the pipeline's output.         output-         -- If we are doing -fno-code, then act as if the output is-         -- 'Temporary'. This stops GHC trying to copy files to their-         -- final location.-         | NoBackend <- backend dflags = Temporary TFL_CurrentModule+         | NoBackend <- backend dflags = NoOutputFile          | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent                 -- -o foo applies to linker          | isJust mb_o_file = SpecificFile                 -- -o foo applies to the file we are compiling now          | otherwise = Persistent -   ( _, out_file, _) <- runPipeline stop_phase hsc_env+   ( _, out_file, _, _) <- runPipeline stop_phase hsc_env                             (src, Nothing, fmap RealPhase mb_phase)                             Nothing                             output@@ -726,8 +696,8 @@   -> PipelineOutput             -- ^ Output filename   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module   -> [FilePath]                 -- ^ foreign objects-  -> IO (DynFlags, FilePath, Maybe ModIface)-                                -- ^ (final flags, output filename, interface)+  -> IO (DynFlags, FilePath, Maybe ModIface, Maybe Linkable)+                                -- ^ (final flags, output filename, interface, linkable) runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)              mb_basename output maybe_loc foreign_os @@ -752,7 +722,8 @@              isHaskell (RealPhase (Cpp   _)) = True              isHaskell (RealPhase (HsPp  _)) = True              isHaskell (RealPhase (Hsc   _)) = True-             isHaskell (HscOut {})           = True+             isHaskell (HscPostTc {})        = True+             isHaskell (HscBackend {})       = True              isHaskell _                     = False               isHaskellishFile = isHaskell start_phase@@ -780,7 +751,8 @@                        throwGhcExceptionIO (UsageError                                    ("cannot compile this file to desired target: "                                       ++ input_fn))-             HscOut {} -> return ()+             HscPostTc {} -> return ()+             HscBackend {} -> return ()           -- Write input buffer to temp file if requested          input_fn' <- case (start_phase, mb_input_buf) of@@ -856,15 +828,17 @@   -> FilePath                   -- ^ Input filename   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module   -> [FilePath]                 -- ^ foreign objects, if we have one-  -> IO (DynFlags, FilePath, Maybe ModIface)-                                -- ^ (final flags, output filename, interface)+  -> IO (DynFlags, FilePath, Maybe ModIface, Maybe Linkable)+                                -- ^ (final flags, output filename, interface, linkable) runPipeline' start_phase hsc_env env input_fn              maybe_loc foreign_os   = do   -- Execute the pipeline...-  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing }+  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing+                       , maybe_linkable = Nothing }   (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state-  return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state)+  return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state+         , pipeStateLinkable pipe_state )  -- --------------------------------------------------------------------------- -- outer pipeline loop@@ -888,6 +862,7 @@         case output_spec env of         Temporary _ ->             return input_fn+        NoOutputFile -> return input_fn         output ->             do pst <- getPipeState                tmpfs <- hsc_tmpfs <$> getPipeSession@@ -895,9 +870,10 @@                                         stopPhase output (src_basename env)                                         dflags stopPhase (maybe_loc pst)                when (final_fn /= input_fn) $ do-                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")-                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")-                  liftIO $ copyWithHeader logger dflags msg line_prag input_fn final_fn+                  let msg = "Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'"+                      line_prag = "{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n"+                  liftIO $ showPass logger dflags msg+                  liftIO $ copyWithHeader line_prag input_fn final_fn                return final_fn  @@ -914,7 +890,7 @@                                   (text "Running phase" <+> ppr phase)             case phase of-               HscOut {} -> do+               HscBackend {} -> do                    -- Depending on the dynamic-too state, we first run the                    -- backend to generate the non-dynamic objects and then                    -- re-run it to generate the dynamic ones.@@ -1258,7 +1234,7 @@   -- the .hs files resides) to the include path, since this is   -- what gcc does, and it's probably what you want.         let current_dir = takeDirectory basename-            new_includes = addQuoteInclude paths [current_dir]+            new_includes = addImplicitQuoteInclude paths [current_dir]             paths = includePaths dflags0             dflags = dflags0 { includePaths = new_includes } @@ -1271,7 +1247,7 @@                 popts = initParserOpts dflags             eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)             case eimps of-              Left errs -> throwErrors (foldPsMessages mkParserErr errs)+              Left errs -> throwErrors (GhcPsMessage <$> errs)               Right (src_imps,imps,L _ mod_name) -> return                   (Just buf, mod_name, imps, src_imps) @@ -1350,21 +1326,68 @@    -- run the compiler!         let msg hsc_env _ what _ = oneShotMsg hsc_env what-        (result, plugin_hsc_env) <--          liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'-                            mod_summary source_unchanged Nothing (1,1)+        plugin_hsc_env' <- liftIO $ initializePlugins hsc_env' -        -- In the rest of the pipeline use the loaded plugins-        setPlugins (hsc_plugins        plugin_hsc_env)-                   (hsc_static_plugins plugin_hsc_env)-        -- "driver" plugins may have modified the DynFlags so we update them-        setDynFlags (hsc_dflags plugin_hsc_env)+        -- Need to set the knot-tying mutable variable for interface+        -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.+        -- See also Note [hsc_type_env_var hack]+        type_env_var <- liftIO $ newIORef emptyNameEnv+        let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_var = Just (mod, type_env_var) } -        return (HscOut src_flavour mod_name result,-                panic "HscOut doesn't have an input filename")+        status <- liftIO $ hscRecompStatus (Just msg) plugin_hsc_env mod_summary+             source_unchanged Nothing (1, 1) -runPhase (HscOut src_flavour mod_name result) _ = do+        logger <- getLogger+        case status of+            HscUpToDate iface ->+                do liftIO $ touchObjectFile logger dflags o_file+                   -- The .o file must have a later modification date+                   -- than the source file (else we wouldn't get Nothing)+                   -- but we touch it anyway, to keep 'make' happy (we think).+                   setIface iface+                   return (RealPhase StopLn, o_file)+            HscRecompNeeded mb_old_hash -> do+              (tc_result, warnings) <- liftIO $+                 hscTypecheckAndGetWarnings plugin_hsc_env mod_summary++              -- In the rest of the pipeline use the loaded plugins+              setPlugins (hsc_plugins        plugin_hsc_env)+                         (hsc_static_plugins plugin_hsc_env)+              -- "driver" plugins may have modified the DynFlags so we update them+              setDynFlags (hsc_dflags plugin_hsc_env)++              return (HscPostTc mod_summary tc_result warnings mb_old_hash,+                      panic "HscPostTc doesn't have an input filename")++runPhase (HscPostTc mod_summary tc_result tc_warnings mb_old_hash) _ = do+        PipeState{hsc_env=hsc_env'} <- getPipeState+        hscBackendAction <- liftIO $ runHsc hsc_env' $ do+            hscDesugarAndSimplify mod_summary tc_result tc_warnings mb_old_hash+         dflags <- getDynFlags+        let hscBackendPhase = HscBackend mod_summary hscBackendAction+        next_phase <- case hscBackendAction of+          HscUpdate iface -> do+            setIface iface+            -- Need to set a fake linkable+            let setLinkableAndStop = do+                  unless (isHsBootOrSig $ ms_hsc_src mod_summary) $+                    setLinkable (LM (ms_hs_date mod_summary) (ms_mod mod_summary) [])+                  return $ RealPhase StopLn+            case backend dflags of+              NoBackend -> setLinkableAndStop+              Interpreter -> setLinkableAndStop+              _ -> return hscBackendPhase -- Need to create .o, and handle -dynamic-too+          _ -> return hscBackendPhase++        return (next_phase,+               panic "HscBackend doesn't have an input filename")++runPhase (HscBackend mod_summary result) _ = do+        let mod_name = moduleName (ms_mod mod_summary)+            src_flavour = (ms_hsc_src mod_summary)++        dflags <- getDynFlags         logger <- getLogger         location <- getLocation src_flavour mod_name         setModLocation location@@ -1373,35 +1396,63 @@             next_phase = hscPostBackendPhase src_flavour (backend dflags)          case result of-            HscNotGeneratingCode _ _ ->-                return (RealPhase StopLn,-                        panic "No output filename from Hsc when no-code")-            HscUpToDate _ _ ->-                do liftIO $ touchObjectFile logger dflags o_file-                   -- The .o file must have a later modification date-                   -- than the source file (else we wouldn't get Nothing)-                   -- but we touch it anyway, to keep 'make' happy (we think).-                   return (RealPhase StopLn, o_file)-            HscUpdateBoot _ _ ->-                do -- In the case of hs-boot files, generate a dummy .o-boot-                   -- stamp file for the benefit of Make-                   liftIO $ touchObjectFile logger dflags o_file-                   return (RealPhase StopLn, o_file)-            HscUpdateSig _ _ ->-                do -- We need to create a REAL but empty .o file-                   -- because we are going to attempt to put it in a library-                   PipeState{hsc_env=hsc_env'} <- getPipeState-                   let input_fn = expectJust "runPhase" (ml_hs_file location)-                       basename = dropExtension input_fn-                   liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name+            HscUpdate iface ->+                do+                   case src_flavour of+                     HsigFile -> do+                       -- We need to create a REAL but empty .o file+                       -- because we are going to attempt to put it in a library+                       PipeState{hsc_env=hsc_env'} <- getPipeState+                       let input_fn = expectJust "runPhase" (ml_hs_file location)+                           basename = dropExtension input_fn+                       liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name++                     -- In the case of hs-boot files, generate a dummy .o-boot+                     -- stamp file for the benefit of Make+                     HsBootFile -> liftIO $ touchObjectFile logger dflags o_file+                     HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"++                   setIface iface                    return (RealPhase StopLn, o_file)             HscRecomp { hscs_guts = cgguts,                         hscs_mod_location = mod_location,                         hscs_partial_iface = partial_iface,                         hscs_old_iface_hash = mb_old_iface_hash                       }-              -> do output_fn <- phaseOutputFilename next_phase+              -> case backend dflags of+                NoBackend -> panic "HscRecomp not relevant for NoBackend"+                Interpreter -> do+                    PipeState{hsc_env=hsc_env'} <- getPipeState+                    -- In interpreted mode the regular codeGen backend is not run so we+                    -- generate a interface without codeGen info.+                    final_iface <- liftIO $ mkFullIface hsc_env' partial_iface Nothing+                    liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location +                    (hasStub, comp_bc, spt_entries) <- liftIO $ hscInteractive hsc_env' cgguts mod_location++                    stub_o <- liftIO $ case hasStub of+                              Nothing -> return []+                              Just stub_c -> do+                                  stub_o <- compileStub hsc_env' stub_c+                                  return [DotO stub_o]++                    let hs_unlinked = [BCOs comp_bc spt_entries]+                        unlinked_time = ms_hs_date mod_summary+                      -- Why do we use the timestamp of the source file here,+                      -- rather than the current time?  This works better in+                      -- the case where the local clock is out of sync+                      -- with the filesystem's clock.  It's just as accurate:+                      -- if the source is modified, then the linkable will+                      -- be out of date.+                    let !linkable = LM unlinked_time (ms_mod mod_summary)+                                   (hs_unlinked ++ stub_o)+                    setIface final_iface+                    setLinkable linkable+                    return (RealPhase StopLn,+                            panic "Interpreter backend doesn't have an output file")+                _ -> do+                    output_fn <- phaseOutputFilename next_phase+                     PipeState{hsc_env=hsc_env'} <- getPipeState                      (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $@@ -1474,7 +1525,8 @@         let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []               (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)         let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-              (includePathsQuote cmdline_include_paths)+              (includePathsQuote cmdline_include_paths +++               includePathsQuoteImplicit cmdline_include_paths)         let include_paths = include_paths_quote ++ include_paths_global          -- pass -D or -optP to preprocessor when compiling foreign C files@@ -1598,12 +1650,14 @@          -- LLVM from version 3.0 onwards doesn't support the OS X system         -- assembler, so we use clang as the assembler instead. (#5636)-        let as_prog | backend dflags == LLVM+        let (as_prog, get_asm_info) | backend dflags == LLVM                     , platformOS platform == OSDarwin-                    = GHC.SysTools.runClang+                    = (GHC.SysTools.runClang, pure Clang)                     | otherwise-                    = GHC.SysTools.runAs+                    = (GHC.SysTools.runAs, liftIO $ getAssemblerInfo logger dflags) +        asmInfo <- get_asm_info+         let cmdline_include_paths = includePaths dflags         let pic_c_flags = picCCOpts dflags @@ -1614,11 +1668,11 @@         -- might be a hierarchical module.         liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) -        ccInfo <- liftIO $ getCompilerInfo logger dflags         let global_includes = [ GHC.SysTools.Option ("-I" ++ p)                               | p <- includePathsGlobal cmdline_include_paths ]         let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)-                             | p <- includePathsQuote cmdline_include_paths ]+                             | p <- includePathsQuote cmdline_include_paths +++                                includePathsQuoteImplicit cmdline_include_paths]         let runAssembler inputFilename outputFilename               = liftIO $                   withAtomicRename outputFilename $ \temp_outputFilename ->@@ -1643,7 +1697,7 @@                        ++ (if platformArch (targetPlatform dflags) == ArchSPARC                            then [GHC.SysTools.Option "-mcpu=v9"]                            else [])-                       ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]+                       ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51]                             then [GHC.SysTools.Option "-Qunused-arguments"]                             else [])                        ++ [ GHC.SysTools.Option "-x"@@ -1818,47 +1872,33 @@      PipeEnv{ src_basename=basename,              src_suffix=suff } <- getPipeEnv-    PipeState { maybe_loc=maybe_loc} <- getPipeState-    case maybe_loc of-        -- Build a ModLocation to pass to hscMain.-        -- The source filename is rather irrelevant by now, but it's used-        -- by hscMain for messages.  hscMain also needs-        -- the .hi and .o filenames. If we already have a ModLocation-        -- then simply update the extensions of the interface and object-        -- files to match the DynFlags, otherwise use the logic in Finder.-      Just l -> return $ l-        { ml_hs_file = Just $ basename <.> suff-        , ml_hi_file = ml_hi_file l -<.> hiSuf dflags-        , ml_obj_file = ml_obj_file l -<.> objectSuf dflags-        }-      _ -> do-        location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff+    location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff -        -- Boot-ify it if necessary-        let location2-              | HsBootFile <- src_flavour = addBootSuffixLocnOut location1-              | otherwise                 = location1+    -- Boot-ify it if necessary+    let location2+          | HsBootFile <- src_flavour = addBootSuffixLocnOut location1+          | otherwise                 = location1  -        -- Take -ohi into account if present-        -- This can't be done in mkHomeModuleLocation because-        -- it only applies to the module being compiles-        let ohi = outputHi dflags-            location3 | Just fn <- ohi = location2{ ml_hi_file = fn }-                      | otherwise      = location2+    -- Take -ohi into account if present+    -- This can't be done in mkHomeModuleLocation because+    -- it only applies to the module being compiles+    let ohi = outputHi dflags+        location3 | Just fn <- ohi = location2{ ml_hi_file = fn }+                  | otherwise      = location2 -        -- Take -o into account if present-        -- Very like -ohi, but we must *only* do this if we aren't linking-        -- (If we're linking then the -o applies to the linked thing, not to-        -- the object file for one module.)-        -- Note the nasty duplication with the same computation in compileFile-        -- above-        let expl_o_file = outputFile dflags-            location4 | Just ofile <- expl_o_file-                      , isNoLink (ghcLink dflags)-                      = location3 { ml_obj_file = ofile }-                      | otherwise = location3-        return location4+    -- Take -o into account if present+    -- Very like -ohi, but we must *only* do this if we aren't linking+    -- (If we're linking then the -o applies to the linked thing, not to+    -- the object file for one module.)+    -- Note the nasty duplication with the same computation in compileFile+    -- above+    let expl_o_file = outputFile dflags+        location4 | Just ofile <- expl_o_file+                  , isNoLink (ghcLink dflags)+                  = location3 { ml_obj_file = ofile }+                  | otherwise = location3+    return location4  ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file@@ -1900,7 +1940,8 @@     let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []           (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)     let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-          (includePathsQuote cmdline_include_paths)+          (includePathsQuote cmdline_include_paths +++           includePathsQuoteImplicit cmdline_include_paths)     let include_paths = include_paths_quote ++ include_paths_global      let verbFlags = getVerbFlags dflags
compiler/GHC/HsToCore.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -16,8 +16,6 @@     deSugar, deSugarExpr     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -65,7 +63,7 @@  import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Logger@@ -211,7 +209,7 @@         -- never desugared and compiled (there's no code!)         -- Consequently, this should hold for any ModGuts that make         -- past desugaring. See Note [Identity versus semantic module].-        ; MASSERT( id_mod == mod )+        ; massert (id_mod == mod)          ; foreign_files <- readIORef th_foreign_files_var @@ -298,7 +296,7 @@                             initDsTc $                             dsLExpr tc_expr -    MASSERT( isEmptyMessages tc_msgs )  -- the type-checker isn't doing anything here+    massert (isEmptyMessages tc_msgs)  -- the type-checker isn't doing anything here        -- mb_result is Nothing only when a failure happens in the type-checker,       -- but mb_core_expr is Nothing when a failure happens in the desugarer@@ -698,8 +696,8 @@   = do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs         -- Patching should not change the Name or the type of the Id-       ; MASSERT( getUnique magic_id == getUnique orig_id )-       ; MASSERT( varType magic_id `eqType` varType orig_id )+       ; massert (getUnique magic_id == getUnique orig_id)+       ; massert (varType magic_id `eqType` varType orig_id)         ; return magic_pair }   | otherwise
compiler/GHC/HsToCore/Arrows.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -13,8 +13,6 @@  module GHC.HsToCore.Arrows ( dsProcExpr ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Match@@ -449,7 +447,7 @@         env_ids   = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids -dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids+dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ _ cmd _) env_ids   = dsLCmd ids local_vars stack_ty res_ty cmd env_ids  -- D, xs |- e :: Bool@@ -553,8 +551,8 @@     left_con <- dsLookupDataCon leftDataConName     right_con <- dsLookupDataCon rightDataConName     let-        left_id  = HsConLikeOut noExtField (RealDataCon left_con)-        right_id = HsConLikeOut noExtField (RealDataCon right_con)+        left_id  = mkConLikeTc (RealDataCon left_con)+        right_id = mkConLikeTc (RealDataCon right_con)         left_expr  ty1 ty2 e = noLocA $ HsApp noComments                            (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e         right_expr ty1 ty2 e = noLocA $ HsApp noComments
compiler/GHC/HsToCore/Binds.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -22,8 +22,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr )@@ -62,6 +60,8 @@ import GHC.Types.Var( EvVar ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Data.Maybe@@ -98,7 +98,7 @@   = do { (force_vars, prs) <- dsLHsBinds binds        ; when debugIsOn $          do { xstrict <- xoptM LangExt.Strict-            ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }+            ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) }               -- with -XStrict, even top-level vars are listed as force vars.         ; return (toOL prs) }@@ -1139,7 +1139,7 @@                                    ; if ok                                      then return (\e -> (Lam x (w2 (app e arg))))                                      else return id }  -- this return is irrelevant-dsHsWrapper (WpCast co)       = ASSERT(coercionRole co == Representational)+dsHsWrapper (WpCast co)       = assert (coercionRole co == Representational) $                                 return $ \e -> mkCastDs e co dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm                                    ; return (\e -> App e core_tm) }@@ -1150,7 +1150,7 @@ -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] dsTcEvBinds_s []       = return []-dsTcEvBinds_s (b:rest) = ASSERT( null rest )  -- Zonker ensures null+dsTcEvBinds_s (b:rest) = assert (null rest) $  -- Zonker ensures null                          dsTcEvBinds b  dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
compiler/GHC/HsToCore/Coverage.hs view
@@ -518,13 +518,8 @@ addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e addTickHsExpr e@(HsUnboundVar {})   = return e-addTickHsExpr e@(HsRecFld _ (Ambiguous id _))   = do freeVar id; return e-addTickHsExpr e@(HsRecFld _ (Unambiguous id _)) = do freeVar id; return e+addTickHsExpr e@(HsRecSel _ (FieldOcc id _))   = do freeVar id; return e -addTickHsExpr e@(HsConLikeOut {}) = return e-  -- We used to do a freeVar on a pat-syn builder, but actually-  -- such builders are never in the inScope env, which-  -- doesn't include top level bindings addTickHsExpr e@(HsIPVar {})     = return e addTickHsExpr e@(HsOverLit {})   = return e addTickHsExpr e@(HsOverLabel{})  = return e@@ -548,8 +543,9 @@         liftM2 (NegApp x)                 (addTickLHsExpr e)                 (addTickSyntaxExpr hpcSrcSpan neg)-addTickHsExpr (HsPar x e) =-        liftM (HsPar x) (addTickLHsExprEvalInner e)+addTickHsExpr (HsPar x lpar e rpar) = do+        e' <- addTickLHsExprEvalInner e+        return (HsPar x lpar e' rpar) addTickHsExpr (SectionL x e1 e2) =         liftM2 (SectionL x)                 (addTickLHsExpr e1)@@ -649,6 +645,11 @@         liftM (XExpr . ExpansionExpr . HsExpanded a) $               (addTickHsExpr b) +addTickHsExpr e@(XExpr (ConLikeTc {})) = return e+  -- We used to do a freeVar on a pat-syn builder, but actually+  -- such builders are never in the inScope env, which+  -- doesn't include top level bindings+ addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e                                   ; return (Present x e') }@@ -869,7 +870,9 @@                 (return fix)                 (addTickLHsCmd c3) -}-addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)+addTickHsCmd (HsCmdPar x lpar e rpar) = do+        e' <- addTickLHsCmd e+        return (HsCmdPar x lpar e' rpar) addTickHsCmd (HsCmdCase x e mgs) =         liftM2 (HsCmdCase x)                 (addTickLHsExpr e)@@ -992,11 +995,11 @@   = do  { fields' <- mapM addTickHsRecField fields         ; return (HsRecFields fields' dd) } -addTickHsRecField :: LHsRecField' GhcTc id (LHsExpr GhcTc)-                  -> TM (LHsRecField' GhcTc id (LHsExpr GhcTc))-addTickHsRecField (L l (HsRecField x id expr pun))+addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)+                  -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))+addTickHsRecField (L l (HsFieldBind x id expr pun))         = do { expr' <- addTickLHsExpr expr-             ; return (L l (HsRecField x id expr' pun)) }+             ; return (L l (HsFieldBind x id expr' pun)) }  addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) =
compiler/GHC/HsToCore/Docs.hs view
@@ -209,7 +209,7 @@                     , maybeToList $ fmap unLoc $ con_doc c                     , conArgDocs c)                   | c <- cons, cname <- getConNames c ]-        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, IM.empty)+        fields  = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty)                   | Just flds <- map getRecConArgs_maybe cons                   , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)                   , (L _ n) <- ns ]
compiler/GHC/HsToCore/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -18,8 +18,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Match@@ -70,6 +68,7 @@ import GHC.Data.Bag import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Core.PatSyn import Control.Monad import Data.Void( absurd )@@ -161,19 +160,19 @@  ds_val_bind (is_rec, binds) _body   | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds-  = ASSERT( isRec is_rec )+  = assert (isRec is_rec )     errDsCoreExpr $     hang (text "Recursive bindings for unlifted types aren't allowed:")        2 (vcat (map ppr (bagToList binds)))  -- Ordinary case for bindings; none should be unlifted ds_val_bind (is_rec, binds) body-  = do  { MASSERT( isRec is_rec || isSingletonBag binds )+  = do  { massert (isRec is_rec || isSingletonBag binds)                -- we should never produce a non-recursive list of multiple binds          ; (force_vars,prs) <- dsLHsBinds binds         ; let body' = foldr seqVar body force_vars-        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )+        ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $           case prs of             [] -> return body             _  -> return (Let (Rec prs) body') }@@ -209,8 +208,8 @@                -- so must be simply unboxed   = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))                                      Nothing matches-       ; MASSERT( null args ) -- Functions aren't lifted-       ; MASSERT( isIdHsWrapper co_fn )+       ; massert (null args) -- Functions aren't lifted+       ; massert (isIdHsWrapper co_fn)        ; let rhs' = mkOptTickBox tick rhs        ; return (bindNonRec fun rhs' body) } @@ -245,9 +244,9 @@ -- function in GHC.Tc.Utils.Zonk: -- putSrcSpanDs loc $ do --   { core_expr <- dsExpr e---   ; MASSERT2( exprType core_expr `eqType` hsExprType e---             , ppr e <+> dcolon <+> ppr (hsExprType e) $$---                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )+--   ; massertPpr (exprType core_expr `eqType` hsExprType e)+--                (ppr e <+> dcolon <+> ppr (hsExprType e) $$+--                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr)) --   ; return core_expr } dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr dsLExpr (L loc e) =@@ -267,15 +266,13 @@  dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsExpr (HsVar    _ (L _ id))           = dsHsVar id-dsExpr (HsRecFld _ (Unambiguous id _)) = dsHsVar id-dsExpr (HsRecFld _ (Ambiguous   id _)) = dsHsVar id+dsExpr (HsRecSel _ (FieldOcc id _))    = dsHsVar id dsExpr (HsUnboundVar (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref         -- See Note [Holes] in GHC.Tc.Types.Constraint -dsExpr (HsPar _ e)            = dsLExpr e+dsExpr (HsPar _ _ e _)        = dsLExpr e dsExpr (ExprWithTySig _ e _)  = dsLExpr e -dsExpr (HsConLikeOut _ con)   = dsConLike con dsExpr (HsIPVar {})           = panic "dsExpr: HsIPVar"  dsExpr (HsGetField x _ _)     = absurd x@@ -289,10 +286,11 @@   = do { warnAboutOverflowedOverLit lit        ; dsOverLit lit } -dsExpr e@(XExpr expansion)-  = case expansion of+dsExpr e@(XExpr ext_expr_tc)+  = case ext_expr_tc of       ExpansionExpr (HsExpanded _ b) -> dsExpr b       WrapExpr {}                    -> dsHsWrapped e+      ConLikeTc {}                   -> dsHsWrapped e  dsExpr (NegApp _ (L loc                     (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))@@ -484,7 +482,7 @@               mk_arg (arg_ty, fl)                = case findField (rec_flds rbinds) (flSelector fl) of-                   (rhs:rhss) -> ASSERT( null rhss )+                   (rhs:rhss) -> assert (null rhss )                                  dsLExprNoLP rhs                    []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))              unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty@@ -603,7 +601,7 @@   | null fields   = dsLExpr record_expr   | otherwise-  = ASSERT2( notNull cons_to_upd, ppr expr )+  = assertPpr (notNull cons_to_upd) (ppr expr) $      do  { record_expr' <- dsLExpr record_expr         ; field_binds' <- mapM ds_field fields@@ -633,7 +631,7 @@       -- else we shadow other uses of the record selector       -- Hence 'lcl_id'.  Cf #2735     ds_field (L _ rec_field)-      = do { rhs <- dsLExpr (hsRecFieldArg rec_field)+      = do { rhs <- dsLExpr (hfbRHS rec_field)            ; let fld_id = unLoc (hsRecUpdFieldId rec_field)            ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id)            ; return (idName fld_id, lcl_id, rhs) }@@ -671,7 +669,7 @@                  mk_val_arg fl pat_arg_id                      = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) -                 inst_con = noLocA $ mkHsWrap wrap (HsConLikeOut noExtField con)+                 inst_con = noLocA $ mkHsWrap wrap (mkConLikeTc con)                         -- Reconstruct with the WrapId so that unpacking happens                  wrap = mkWpEvVarApps theta_vars                                <.>                         dict_req_wrap                                           <.>@@ -771,7 +769,7 @@  dsExpr (HsBinTick _ ixT ixF e) = do   e2 <- dsLExpr e-  do { ASSERT(exprType e2 `eqType` boolTy)+  do { assert (exprType e2 `eqType` boolTy)        mkBinaryTickBox ixT ixF e2      } @@ -819,8 +817,8 @@  findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel-  = [hsRecFieldArg fld | L _ fld <- rbinds-                       , sel == idName (unLoc $ hsRecFieldId fld) ]+  = [hfbRHS fld | L _ fld <- rbinds+                       , sel == idName (hsRecFieldId fld) ]  {- %--------------------------------------------------------------------@@ -938,7 +936,7 @@     goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts)      go _ (LastStmt _ body _ _) stmts-      = ASSERT( null stmts ) dsLExpr body+      = assert (null stmts ) dsLExpr body         -- The 'return' op isn't used for 'do' expressions      go _ (BodyStmt _ rhs then_expr _) stmts@@ -1042,13 +1040,18 @@ -}  dsHsVar :: Id -> DsM CoreExpr+-- We could just call dsHsUnwrapped; but this is a short-cut+-- for the very common case of a variable with no wrapper.+-- NB: withDict is always instantiated by a wrapper, so we need+--     only check for it in dsHsUnwrapped dsHsVar var-  = do { checkLevPolyFunction (ppr var) var (idType var)+  = do { checkLevPolyFunction var var (idType var)        ; return (varToCoreExpr var) }   -- See Note [Desugaring vars] -dsConLike :: ConLike -> DsM CoreExpr-dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc)-dsConLike (PatSynCon ps)+dsHsConLike :: ConLike -> DsM CoreExpr+dsHsConLike (RealDataCon dc)+  = return (varToCoreExpr (dataConWrapId dc))+dsHsConLike (PatSynCon ps)   | Just (builder_name, _, add_void) <- patSynBuilder ps   = do { builder_id <- dsLookupGlobalId builder_name        ; return (if add_void@@ -1058,6 +1061,26 @@   | otherwise   = pprPanic "dsConLike" (ppr ps) +dsConLike :: ConLike -> [TcInvisTVBinder] -> [Scaled Type] -> DsM CoreExpr+-- This function desugars ConLikeTc+-- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head+--     for what is going on here+dsConLike con tvbs tys+  = do { ds_con <- dsHsConLike con+       ; ids    <- newSysLocalsDs tys+                   -- newSysLocalDs: /can/ be lev-poly; see+                   -- Note [Checking levity-polymorphic data constructors]+       ; return (mkLams tvs $+                 mkLams ids $+                 ds_con `mkTyApps` mkTyVarTys tvs+                        `mkVarApps` drop_stupid ids) }+  where+    tvs = binderVars tvbs++    drop_stupid = dropList (conLikeStupidTheta con)+    -- drop_stupid: see Note [Instantiating stupid theta]+    --              in GHC.Tc.Gen.Head+ {- ************************************************************************ *                                                                      *@@ -1135,7 +1158,7 @@ is absolutely fine.  Here `f` is a function, represented by a pointer, and we can pass it to `const` (or anything else).  (See #12708 for an example.)  It's only the Id.hasNoBinding functions-that are a problem.+that are a problem.  See checkLevPolyFunction.  Interestingly, this approach does not look to see whether the Id in question will be eta expanded. The logic is this:@@ -1146,6 +1169,62 @@     argument. If its wrapped type contains levity polymorphic arguments, reject. So, either way, we're good to reject. +Note [Nasty wrinkle in levity-polymorphic function check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A nasty wrinkle came up in T13244+   type family Rep x+   type instance Rep Int = IntRep++   type Unboxed x :: TYPE (Rep x)+   type instance Unboxed Int = Int#++   box :: Unboxed Int -> Int+   box = I#++Here the function I# is wrapped in a /cast/, thus+   box = I# |> (co :: (Int# -> Int) ~ (Unboxed Int -> Int))+If we look only at final type of the expression,+  namely: Unboxed Int -> Int,+the kind of the argument type is TYPE (Rep Int), and that needs+type-family reduction to say whether it is lifted or unlifted.++So we split the wrapper into the instantiating part (which is what+we really want) and everything else; see splitWrapper.  This is+very disgusting.++But it also improves the error message in an example like T13233_elab:+  obscure :: (forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep)+                     (a :: TYPE rep1) (b :: TYPE rep2).+                     a -> b -> (# a, b #)) -> ()+  obscure _ = ()++  quux = obscure (#,#)++Around the (#,#) we'll get some type /abstractions/ wrapping some type+/instantiations/. In the levity-poly error message we really only want+to report the instantiations.  Hence passing (mkHsWrap w_inner e) to+checkLevPolyArgs.+++Note [Checking levity-polymorphic data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Similarly, generated by a newtype data constructor, we might get this:+  (/\(r :: RuntimeRep) (a :: TYPE r) \(x::a). K r a x) @LiftedRep Int 4++which we want to accept. See Note [Typechecking data constructors] in+GHC.Tc.Gen.Head.++Because we want to accept this, we switch off Lint's levity-poly checks+when Lint checks the output of the desugarer; see the lf_check_levity_poly+flag in GHC.Core.Lint.lintCoreBindings.++We can get this situation both for levity-polymorphic newtype constructors+(T18481), and for levity-polymorphic algebraic data types, e.g (T18481a)+    type T :: TYPE (BoxedRep r) -> TYPE (BoxedRep r)+    data T a = MkT Int++    f :: T Bool+    f = MkT @Lifted @Bool 42 -}  ------------------------------@@ -1154,39 +1233,73 @@ -- or wrappers (HsWrap), and checks that any hasNoBinding function -- is not levity polymorphic, *after* instantiation with those wrappers dsHsWrapped orig_hs_expr-  = go id orig_hs_expr+  = go idHsWrapper orig_hs_expr   where-    go wrap (XExpr (WrapExpr (HsWrap co_fn hs_e)))-       = do { wrap' <- dsHsWrapper co_fn-            ; addTyCs FromSource (hsWrapDictBinders co_fn) $-              go (wrap . wrap') hs_e }-    go wrap (HsConLikeOut _ (RealDataCon dc))-      = go_head wrap (dataConWrapId dc)-    go wrap (HsAppType ty hs_e _) = go_l (wrap . (\e -> App e (Type ty))) hs_e-    go wrap (HsPar _ hs_e)        = go_l wrap hs_e-    go wrap (HsVar _ (L _ var))   = go_head wrap var-    go wrap hs_e                  = do { e <- dsExpr hs_e; return (wrap e) }+    go wrap (HsPar _ _ (L _ hs_e) _)+       = go wrap hs_e+    go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e)))+       = go (wrap1 <.> wrap2) hs_e+    go wrap (HsAppType ty (L _ hs_e) _)+       = go (wrap <.> WpTyApp ty) hs_e -    go_l wrap (L _ hs_e) = go wrap hs_e+    go wrap e@(XExpr (ConLikeTc con tvs tys))+      = do { let (w_outer, w_inner) = splitWrapper wrap+           ; w_outer' <- dsHsWrapper w_outer+           ; w_inner' <- dsHsWrapper w_inner+           ; ds_con <- dsConLike con tvs tys+           ; let inst_e  = w_inner' ds_con+                 inst_ty = exprType inst_e+           ; checkLevPolyArgs (mkHsWrap w_inner e) inst_ty+           ; return (w_outer' inst_e) } -    go_head wrap var+    go wrap e@(HsVar _ (L _ var))       | var `hasKey` withDictKey-      = ds_withDict wrapped_ty+      = do { wrap' <- dsHsWrapper wrap+           ; ds_withDict (exprType (wrap' (varToCoreExpr var))) }        | otherwise-      = do { checkLevPolyFunction (ppr orig_hs_expr) var wrapped_ty-             -- See Note [Checking for levity-polymorphic functions]-             -- Pass orig_hs_expr, so that the user can see entire-             -- expression with -fprint-typechecker-elaboration-+      = do { let (w_outer, w_inner) = splitWrapper wrap+           ; w_outer' <- dsHsWrapper w_outer+           ; w_inner' <- dsHsWrapper w_inner+           ; let inst_e  = w_inner' (varToCoreExpr var)+                 inst_ty = exprType inst_e+           ; checkLevPolyFunction (mkHsWrap w_inner e) var inst_ty            ; dflags <- getDynFlags-           ; warnAboutIdentities dflags var wrapped_ty+           ; warnAboutIdentities dflags var inst_ty+           ; return (w_outer' inst_e) } -           ; return wrapped_e }-      where-        wrapped_e  = wrap (Var var)-        wrapped_ty = exprType wrapped_e+    go wrap hs_e+       = do { wrap' <- dsHsWrapper wrap+            ; addTyCs FromSource (hsWrapDictBinders wrap) $+              do { e <- dsExpr hs_e+                 ; return (wrap' e) } } +splitWrapper :: HsWrapper -> (HsWrapper, HsWrapper)+-- Split a wrapper w into (outer_wrap <.> inner_wrap), where+-- inner_wrap does instantiation (type and evidence application)+-- and outer_wrap is everything else, such as a final cast+-- See Note [Nasty wrinkle in levity-polymorphic function check]+splitWrapper wrap+  = go WpHole wrap+  where+    go :: HsWrapper -> HsWrapper -> (HsWrapper, HsWrapper)+    -- If (go w1 w2) = (w3,w4) then+    --    - w1 <.> w2  = w3 <.> w4+    --    - w4 does instantiation only ("instantiator" below)+    -- 'go' mainly dispatches on w2, using w1 as a work-list+    -- onto which it pushes stuff in w2 to come back to later+    go WpHole WpHole              = (WpHole,WpHole)+    go w      WpHole              = splitWrapper w+    go w1     (w2 `WpCompose` w3) = go (w1 <.> w2) w3++    go w1 w2 | instantiator w2  = liftSnd (<.> w2) (splitWrapper w1)+             | otherwise        = (w1 <.> w2, WpHole)++    instantiator (WpTyApp {}) = True+    instantiator (WpEvApp {}) = True+    instantiator _            = False++ -- See Note [withDict] ds_withDict :: Type -> DsM CoreExpr ds_withDict wrapped_ty@@ -1204,18 +1317,17 @@   , Just (inst_meth_ty, co) <- instNewTyCon_maybe dict_tc dict_args     -- Check that `st` is equal to `meth_ty[t_i/a_i]`.   , st `eqType` inst_meth_ty-  = let sv = mkScaledTemplateLocal 1 $ mkScaled mult1 st-        k  = mkScaledTemplateLocal 2 $ mkScaled mult2 dt_to_r in-    pure $ mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co)+  = do { sv <- newSysLocalDs mult1 st+       ; k  <- newSysLocalDs mult2 dt_to_r+       ; pure $ mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co) }    | otherwise   = errDsCoreExpr $ hang (text "Invalid instantiation of" <+>                           quotes (ppr withDictName) <+> text "at type:")                        4 (ppr wrapped_ty) -{--Note [withDict]-~~~~~~~~~~~~~~~+{- Note [withDict]+~~~~~~~~~~~~~~~~~~ The identifier `withDict` is just a place-holder, which is used to implement a primitive that we cannot define in Haskell but we can write in Core.  It is declared with a place-holder type:@@ -1346,13 +1458,29 @@ -- instantiated type.  If the function is a hasNoBinding op, and the -- type has levity-polymorphic arguments, issue an error. -- Note [Checking for levity-polymorphic functions]-checkLevPolyFunction :: SDoc -> Id -> Type -> DsM ()-checkLevPolyFunction pp_hs_expr var ty-  | let bad_tys = isBadLevPolyFunction var ty+checkLevPolyFunction :: Outputable e => e -> Id -> Type -> DsM ()+checkLevPolyFunction orig_hs_expr var ty+  | hasNoBinding var+  = checkLevPolyArgs orig_hs_expr ty+  | otherwise+  = return ()++checkLevPolyArgs :: Outputable e => e -> Type -> DsM ()+-- Check that there are no levity-polymorphic arguments in+-- the supplied type+-- E.g. Given (forall a. t1 -> t2 -> blah), ensure that t1,t2+--      are not levity-polymorhic+--+-- Pass orig_hs_expr, so that the user can see entire thing+-- Note [Checking for levity-polymorphic functions]+checkLevPolyArgs orig_hs_expr ty+  | let (binders, _) = splitPiTys ty+        arg_tys      = mapMaybe binderRelevantType_maybe binders+        bad_tys      = filter isTypeLevPoly arg_tys   , not (null bad_tys)   = errDs $ vcat     [ hang (text "Cannot use function with levity-polymorphic arguments:")-         2 (pp_hs_expr <+> dcolon <+> pprWithTYPE ty)+         2 (hang (ppr orig_hs_expr) 2 (dcolon <+> pprWithTYPE ty))     , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat         [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"         , text "are eta-expanded internally because they must occur fully saturated."@@ -1364,18 +1492,4 @@            bad_tys     ] -checkLevPolyFunction _ _ _ = return ()---- | Is this a hasNoBinding Id with a levity-polymorphic type?--- Returns the arguments that are levity polymorphic if they are bad;--- or an empty list otherwise--- Note [Checking for levity-polymorphic functions]-isBadLevPolyFunction :: Id -> Type -> [Type]-isBadLevPolyFunction id ty-  | hasNoBinding id-  = filter isTypeLevPoly arg_tys-  | otherwise-  = []-  where-    (binders, _) = splitPiTys ty-    arg_tys      = mapMaybe binderRelevantType_maybe binders+  | otherwise = return ()
compiler/GHC/HsToCore/Foreign/Call.hs view
@@ -6,8 +6,8 @@ Desugaring foreign calls -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.HsToCore.Foreign.Call@@ -19,8 +19,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core@@ -46,8 +44,8 @@ import GHC.Builtin.Names import GHC.Driver.Session import GHC.Utils.Outputable-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Data.Maybe @@ -120,7 +118,7 @@ --      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr)) --                      a b s x c mkFCall dflags uniq the_fcall val_args res_ty-  = ASSERT( all isTyVar tyvars )  -- this must be true because the type is top-level+  = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level     mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args   where     arg_tys = map exprType val_args@@ -163,7 +161,7 @@   -- Data types with a single constructor, which has a single, primitive-typed arg   -- This deals with Int, Float etc; also Ptr, ForeignPtr   | is_product_type && data_con_arity == 1-  = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)+  = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $                         -- Typechecker ensures this     do case_bndr <- newSysLocalDs Many arg_ty        prim_arg <- newSysLocalDs Many data_con_arg_ty1@@ -289,7 +287,7 @@  mk_alt return_result (Just prim_res_ty, wrap_result)   = -- The ccall returns a non-() value-    ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )+    assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $              -- True because resultWrapper ensures it is so     do { result_id <- newSysLocalDs Many prim_res_ty        ; state_id <- newSysLocalDs Many realWorldStatePrimTy
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -14,7 +14,6 @@  module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where -#include "GhclibHsVersions.h" import GHC.Prelude  import GHC.Tc.Utils.Monad        -- temp@@ -57,8 +56,8 @@ import GHC.Driver.Config import GHC.Platform import GHC.Data.OrdList-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Driver.Hooks import GHC.Utils.Encoding @@ -174,7 +173,7 @@                  IsFunction              _ -> IsData    (resTy, foRhs) <- resultWrapper ty-   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this+   assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this     let         rhs = foRhs (Lit (LitLabel cid stdcall_info fod))         rhs' = Cast rhs co@@ -819,8 +818,8 @@   | otherwise =   case splitDataProductType_maybe rep_ty of      Just (_, _, data_con, [Scaled _ prim_ty]) ->-        ASSERT(dataConSourceArity data_con == 1)-        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)+        assert (dataConSourceArity data_con == 1) $+        assertPpr (isUnliftedType prim_ty) (ppr prim_ty)         prim_ty      _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)   where
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -10,8 +10,6 @@  module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsLocalBinds )@@ -30,6 +28,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Core.Multiplicity import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList )@@ -63,8 +62,8 @@                                        --   one for each GRHS.         -> DsM (MatchResult CoreExpr) dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas-  = ASSERT( notNull grhss )-    do { match_results <- ASSERT( length grhss == length rhss_nablas )+  = assert (notNull grhss) $+    do { match_results <- assert (length grhss == length rhss_nablas) $                           zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss        ; nablas <- getPmNablas        -- We need to remember the Nablas from the particular match context we
compiler/GHC/HsToCore/ListComp.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP            #-}+ {-# LANGUAGE TypeFamilies   #-}  {-@@ -11,8 +11,6 @@  module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )@@ -35,9 +33,9 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Tc.Utils.TcType import GHC.Data.List.SetOps( getNth )-import GHC.Utils.Misc  {- List comprehensions may be desugared in one of two ways: ``ordinary''@@ -222,7 +220,7 @@  deListComp (LastStmt _ body _ _ : quals) list   =     -- Figure 7.4, SLPJ, p 135, rule C above-    ASSERT( null quals )+    assert (null quals) $     do { core_body <- dsLExpr body        ; return (mkConsExpr (exprType core_body) core_body list) } @@ -329,7 +327,7 @@ dfListComp _ _ [] = panic "dfListComp"  dfListComp c_id n_id (LastStmt _ body _ _ : quals)-  = ASSERT( null quals )+  = assert (null quals) $     do { core_body <- dsLExprNoLP body        ; return (mkApps (Var c_id) [core_body, Var n_id]) } @@ -485,7 +483,7 @@ dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr  dsMcStmt (LastStmt _ body _ ret_op) stmts-  = ASSERT( null stmts )+  = assert (null stmts) $     do { body' <- dsLExpr body        ; dsSyntaxExpr ret_op [body'] }
compiler/GHC/HsToCore/Match.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeFamilies #-}@@ -20,8 +20,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -61,6 +59,7 @@ import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM@@ -184,15 +183,15 @@       -> DsM (MatchResult CoreExpr) -- ^ Desugared result!  match [] ty eqns-  = ASSERT2( not (null eqns), ppr ty )+  = assertPpr (not (null eqns)) (ppr ty) $     return (foldr1 combineMatchResults match_results)   where-    match_results = [ ASSERT( null (eqn_pats eqn) )+    match_results = [ assert (null (eqn_pats eqn)) $                       eqn_rhs eqn                     | eqn <- eqns ]  match (v:vs) ty eqns    -- Eqns *can* be empty-  = ASSERT2( all (isInternalName . idName) vars, ppr vars )+  = assertPpr (all (isInternalName . idName) vars) (ppr vars) $     do  { dflags <- getDynFlags         ; let platform = targetPlatform dflags                 -- Tidy the first pattern, generating@@ -422,7 +421,7 @@ -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v o (ParPat _ pat)      = tidy1 v o (unLoc pat)+tidy1 v o (ParPat _ _ pat _)  = tidy1 v o (unLoc pat) tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat) tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty) tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p@@ -518,7 +517,7 @@               -> DsM (DsWrapper, Pat GhcTc)  -- Discard par/sig under a bang-tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p+tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p  -- Push the bang-pattern inwards, in the hope that@@ -574,13 +573,13 @@ -- See Note [Bang patterns and newtypes] -- We are transforming   !(N p)   into   (N !p) push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))-  = ASSERT( null args)+  = assert (null args) $     PrefixCon ts [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf)   | HsRecFields { rec_flds = L lf fld : flds } <- rf-  , HsRecField { hsRecFieldArg = arg } <- fld-  = ASSERT( null flds)-    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg+  , HsFieldBind { hfbRHS = arg } <- fld+  = assert (null flds) $+    RecCon (rf { rec_flds = [L lf (fld { hfbRHS                                            = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})   | HsRecFields { rec_flds = [] } <- rf@@ -873,7 +872,7 @@                   -> HsMatchContext GhcRn -> LPat GhcTc                   -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) matchSinglePatVar var mb_scrut ctx pat ty match_result-  = ASSERT2( isInternalName (idName var), ppr var )+  = assertPpr (isInternalName (idName var)) (ppr var) $     do { dflags <- getDynFlags        ; locn   <- getSrcSpanDs        -- Pattern match check warnings@@ -1053,8 +1052,8 @@     exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool     -- real comparison is on HsExpr's     -- strip parens-    exp (HsPar _ (L _ e)) e'   = exp e e'-    exp e (HsPar _ (L _ e'))   = exp e e'+    exp (HsPar _ _ (L _ e) _) e' = exp e e'+    exp e (HsPar _ _ (L _ e') _) = exp e e'     -- because the expressions do not necessarily have the same type,     -- we have to compare the wrappers     exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap  h' e'))) =@@ -1062,7 +1061,7 @@     exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =       exp b b'     exp (HsVar _ i) (HsVar _ i') =  i == i'-    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'+    exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c'     -- the instance for IPName derives using the id, so this works if the     -- above does     exp (HsIPVar _ i) (HsIPVar _ i') = i == i'@@ -1171,7 +1170,7 @@     (HsFractional f, is_neg)       | is_neg    -> PgN $! negateFractionalLit f       | otherwise -> PgN f-    (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)+    (HsIsString _ s, _) -> assert (isNothing mb_neg) $                             PgOverS s patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =   case oval of
compiler/GHC/HsToCore/Match/Constructor.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -13,8 +13,6 @@  module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Match ( match )@@ -36,6 +34,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad(liftM) import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty(..))@@ -133,10 +132,10 @@                 -> NonEmpty EquationInfo                 -> DsM (CaseAlt ConLike) matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single constructor-  = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )+  = do  { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $                            -- ex_tvs can only be tyvars as data types in source                            -- Haskell cannot mention covar yet (Aug 2018).-                         ASSERT( tvs1 `equalLength` ex_tvs )+                         assert (tvs1 `equalLength` ex_tvs) $                          arg_tys ++ mkTyVarTys tvs1                val_arg_tys = conLikeInstOrigArgTys con1 inst_tys@@ -147,7 +146,7 @@                           -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr)               -- All members of the group have compatible ConArgPats               match_group arg_vars arg_eqn_prs-                = ASSERT( notNull arg_eqn_prs )+                = assert (notNull arg_eqn_prs) $                   do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)                      ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs                      ; match_result <- match (group_arg_vars ++ vars) ty eqns'@@ -216,15 +215,15 @@       | RecCon flds <- arg_pats       , let rpats = rec_flds flds       , not (null rpats)     -- Treated specially; cf conArgPats-      = ASSERT2( fields1 `equalLength` arg_vars,-                 ppr con1 $$ ppr fields1 $$ ppr arg_vars )+      = assertPpr (fields1 `equalLength` arg_vars)+                  (ppr con1 $$ ppr fields1 $$ ppr arg_vars) $         map lookup_fld rpats       | otherwise       = arg_vars       where         fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars         lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env-                                            (idName (unLoc (hsRecFieldId rpat)))+                                            (idName (hsRecFieldId rpat))     select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"  -----------------@@ -240,7 +239,7 @@             -> Bool same_fields flds1 flds2   = all2 (\(L _ f1) (L _ f2)-                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))+                          -> hsRecFieldId f1 == hsRecFieldId f2)          (rec_flds flds1) (rec_flds flds2)  @@ -264,7 +263,7 @@   | null rpats = map WildPat (map scaledThing arg_tys)         -- Important special case for C {}, which can be used for a         -- datacon that isn't declared to have fields at all-  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats+  | otherwise  = map (unLoc . hfbRHS . unLoc) rpats  {- Note [Record patterns]
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE TypeApplications    #-}@@ -24,8 +24,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -56,6 +54,7 @@ import GHC.Driver.Session import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )@@ -204,7 +203,7 @@         !denom = mkIntegerExpr (denominator val)         (ratio_data_con, integer_ty)             = case tcSplitTyConApp ty of-                    (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)+                    (tycon, [i_ty]) -> assert (isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)                                        (head (tyConDataCons tycon), i_ty)                     x -> pprPanic "dsLit" (ppr x)     in return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])@@ -448,7 +447,7 @@ -- ^ See if the expression is an 'Integral' literal. getLHsIntegralLit (L _ e) = go e   where-    go (HsPar _ e)            = getLHsIntegralLit e+    go (HsPar _ _ e _)        = getLHsIntegralLit e     go (HsOverLit _ over_lit) = getIntegralLit over_lit     go (HsLit _ lit)          = getSimpleIntegralLit lit @@ -479,7 +478,7 @@  -- | Extract the Char if the expression is a Char literal. getLHsCharLit :: LHsExpr GhcTc -> Maybe Char-getLHsCharLit (L _ (HsPar _ e))            = getLHsCharLit e+getLHsCharLit (L _ (HsPar _ _ e _))        = getLHsCharLit e getLHsCharLit (L _ (HsTick _ _ e))         = getLHsCharLit e getLHsCharLit (L _ (HsBinTick _ _ _ e))    = getLHsCharLit e getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c
compiler/GHC/HsToCore/Monad.hs view
@@ -109,6 +109,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic+import qualified GHC.Data.Strict as Strict  import Data.IORef @@ -454,7 +455,7 @@  getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv-                  ; return (RealSrcSpan (dsl_loc env) Nothing) }+                  ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }  putSrcSpanDs :: SrcSpan -> DsM a -> DsM a putSrcSpanDs (UnhelpfulSpan {}) thing_inside@@ -474,7 +475,7 @@        ; dflags <- getDynFlags        ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) $                    DsUnknownMessage $-                   mkPlainDiagnostic reason warn+                   mkPlainDiagnostic reason noHints warn        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }  -- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags@@ -489,7 +490,7 @@         ; loc <- getSrcSpanDs         ; let msg = mkErrorMsgEnvelope loc (ds_unqual env) $                     DsUnknownMessage $-                    mkPlainError err+                    mkPlainError noHints err         ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }  -- | Issue an error, but return the expression for (), so that we can continue
compiler/GHC/HsToCore/Pmc.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP               #-}+ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs             #-} {-# LANGUAGE LambdaCase        #-}@@ -40,8 +40,6 @@         -- See Note [Long-distance information]         addTyCs, addCoreScrutTmCs, addHsScrutTmCs     ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/HsToCore/Pmc/Check.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP               #-}+ {-# LANGUAGE DeriveFunctor     #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs             #-}@@ -21,8 +21,6 @@         CheckAction(..),         checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase     ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/HsToCore/Pmc/Desugar.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP               #-}+ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs             #-} {-# LANGUAGE LambdaCase        #-}@@ -13,8 +13,6 @@       desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Pmc.Types@@ -33,7 +31,6 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc import GHC.Core.DataCon import GHC.Types.Var (EvVar) import GHC.Core.Coercion@@ -111,7 +108,7 @@ desugarPat x pat = case pat of   WildPat  _ty -> pure []   VarPat _ y   -> pure (mkPmLetVar (unLoc y) x)-  ParPat _ p   -> desugarLPat x p+  ParPat _ _ p _ -> desugarLPat x p   LazyPat _ _  -> pure [] -- like a wildcard   BangPat _ p@(L l p') ->     -- Add the bang in front of the list, because it will happen before any@@ -290,7 +287,7 @@     -- LHsRecField     rec_field_ps fs = map (tagged_pat . unLoc) fs       where-        tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hsRecFieldArg f)+        tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hfbRHS f)         -- Unfortunately the label info is empty when the DataCon wasn't defined         -- with record field labels, hence we desugar to field index.         orig_lbls        = map flSelector $ conLikeFieldLabels con@@ -405,7 +402,8 @@       let go_export :: ABExport GhcTc -> Maybe PmGrd           go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap}             | isIdHsWrapper wrap-            = ASSERT2(idType x `eqType` idType y, ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y))+            = assertPpr (idType x `eqType` idType y)+                        (ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y)) $               Just $ PmLet x (Var y)             | otherwise             = Nothing
compiler/GHC/HsToCore/Pmc/Ppr.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for@@ -8,8 +8,6 @@         pprUncovered     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Basic@@ -21,8 +19,8 @@ import GHC.Builtin.Types import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad.Trans.RWS.CPS-import GHC.Utils.Misc import GHC.Data.Maybe import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) @@ -203,8 +201,8 @@      go_con rev_pref (PmAltConLike (RealDataCon c)) es       | c == nilDataCon-      = ASSERT( null es ) Just (NilTerminated (reverse rev_pref))+      = assert (null es) $ Just (NilTerminated (reverse rev_pref))       | c == consDataCon-      = ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)+      = assert (length es == 2) $ go_var (es !! 0 : rev_pref) (es !! 1)     go_con _ _ _       = Nothing
compiler/GHC/HsToCore/Pmc/Solver.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns        #-}@@ -34,8 +34,6 @@      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Pmc.Types@@ -47,6 +45,7 @@ import GHC.Utils.Misc import GHC.Utils.Monad (allM) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.CompleteMatch import GHC.Types.Unique.Set@@ -397,7 +396,7 @@   = case splitTyConApp_maybe ty of       Just (tc, ty_args)              | is_algebraic_like tc && not (isFamilyTyCon tc)-             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True+             -> assertPpr (ty_args `lengthIs` tyConArity tc) (ppr ty) True       _other -> False   where     -- This returns True for TyCons which /act like/ algebraic types.@@ -796,7 +795,7 @@             -- See Note [Completeness checking with required Thetas]             | hasRequiredTheta nalt  = neg             | otherwise              = extendPmAltConSet neg nalt-      MASSERT( isPmAltConMatchStrict nalt )+      massert (isPmAltConMatchStrict nalt)       let vi' = vi{ vi_neg = neg', vi_bot = IsNotBot }       -- 3. Make sure there's at least one other possible constructor       mb_rcm' <- lift (markMatched nalt rcm)@@ -853,7 +852,7 @@             MaybeBot -> pure (nabla_with MaybeBot)             IsBot    -> addBotCt (nabla_with MaybeBot) y             IsNotBot -> addNotBotCt (nabla_with MaybeBot) y-        _ -> ASSERT( isPmAltConMatchStrict alt )+        _ -> assert (isPmAltConMatchStrict alt )              pure (nabla_with IsNotBot) -- strict match ==> not ⊥  equateTys :: [Type] -> [Type] -> [PhiCt]
compiler/GHC/HsToCore/Pmc/Solver/Types.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE ApplicativeDo       #-}-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-}  -- | Domain types used in "GHC.HsToCore.Pmc.Solver".@@ -32,11 +32,8 @@      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -import GHC.Utils.Misc import GHC.Data.Bag import GHC.Data.FastString import GHC.Types.Id@@ -47,7 +44,7 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.List.SetOps (unionLists) import GHC.Data.Maybe import GHC.Core.Type@@ -59,7 +56,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim-import GHC.Tc.Solver.Monad (InertSet, emptyInert)+import GHC.Tc.Solver.InertSet (InertSet, emptyInert) import GHC.Tc.Utils.TcType (isStringTy) import GHC.Types.CompleteMatch (CompleteMatch(..)) import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit@@ -431,7 +428,7 @@  -- | Type of a 'PmAltCon' pmAltConType :: PmAltCon -> [Type] -> Type-pmAltConType (PmAltLit lit)     _arg_tys = ASSERT( null _arg_tys ) pmLitType lit+pmAltConType (PmAltLit lit)     _arg_tys = assert (null _arg_tys ) $ pmLitType lit pmAltConType (PmAltConLike con) arg_tys  = conLikeResTy con arg_tys  -- | Is a match on this constructor forcing the match variable?
compiler/GHC/HsToCore/Pmc/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns        #-}@@ -33,8 +33,6 @@         module GHC.HsToCore.Pmc.Solver.Types      ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/HsToCore/Pmc/Utils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-}  -- | Utility module for the pattern-match coverage checker.@@ -10,8 +10,6 @@         isMatchContextPmChecked, needToRunPmCheck      ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/HsToCore/Quote.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE CPP                    #-}+ {-# LANGUAGE DataKinds              #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FunctionalDependencies #-}@@ -29,8 +29,6 @@  module GHC.HsToCore.Quote( dsBracket ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -65,6 +63,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad @@ -128,7 +127,7 @@                           mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars)))                                            (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) -      MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty)+      massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty)        let m_ty = Type m_var           -- Construct the contents of MetaWrappers@@ -285,7 +284,7 @@                         , hs_docs    = docs })  = do { let { bndrs  = hsScopedTvBinders valds                        ++ hsGroupBinders group-                       ++ map extFieldOcc (hsPatSynSelectors valds)+                       ++ map foExt (hsPatSynSelectors valds)             ; instds = tyclds >>= group_instds } ;         ss <- mkGenSyms bndrs ; @@ -1487,9 +1486,7 @@ repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar repE (HsOverLabel _ s) = repOverLabel s -repE e@(HsRecFld _ f) = case f of-  Unambiguous x _ -> repE (HsVar noExtField (noLocA x))-  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)+repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))          -- Remember, we're desugaring renamer output here, so         -- HsOverlit can definitely occur@@ -1514,7 +1511,7 @@                               a         <- repLE x                               negateVar <- lookupOcc negateName >>= repVar                               negateVar `repApp` a-repE (HsPar _ x)            = repLE x+repE (HsPar _ _ x _)        = repLE x repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b } repE (HsCase _ e (MG { mg_alts = (L _ ms) }))@@ -1708,17 +1705,17 @@   where     rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)             -> MetaM (Core (M TH.FieldExp))-    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)-                           ; e  <- repLE (hsRecFieldArg fld)+    rep_fld (L _ fld) = do { fn <- lookupOcc (hsRecFieldSel fld)+                           ; e  <- repLE (hfbRHS fld)                            ; repFieldExp fn e }  repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) repUpdFields = repListM fieldExpTyConName rep_fld   where     rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp))-    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of+    rep_fld (L l fld) = case unLoc (hfbLHS fld) of       Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)-                                   ; e  <- repLE (hsRecFieldArg fld)+                                   ; e  <- repLE (hfbRHS fld)                                    ; repFieldExp fn e }       Ambiguous{}            -> notHandled "Ambiguous record updates" (ppr fld) @@ -1796,7 +1793,7 @@        -- Bring all of binders in the recursive group into scope for the        -- whole group.        ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (unLoc $ recS_stmts stmt))-       ; MASSERT(sort ss1 == sort ss1_other)+       ; massert (sort ss1 == sort ss1_other)        ; z <- repRecSt (nonEmptyCoreList rss)        ; (ss2,zs) <- addBinds ss1 (repSts ss)        ; return (ss1++ss2, z : zs) }@@ -1930,7 +1927,7 @@     mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]     mkGenArgSyms (RecCon fields)       = do { let pats = map (unLoc . recordPatSynPatVar) fields-                 sels = map (extFieldOcc . recordPatSynField) fields+                 sels = map (foExt . recordPatSynField) fields            ; ss <- mkGenSyms sels            ; return $ replaceNames (zip sels pats) ss } @@ -1960,7 +1957,7 @@        ; arg2' <- lookupLOcc arg2        ; repInfixPatSynArgs arg1' arg2' } repPatSynArgs (RecCon fields)-  = do { sels' <- repList nameTyConName (lookupOcc . extFieldOcc) sels+  = do { sels' <- repList nameTyConName (lookupOcc . foExt) sels        ; repRecordPatSynArgs sels' }   where sels = map recordPatSynField fields @@ -2044,7 +2041,7 @@ repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 } repP (AsPat _ x p)      = do { x' <- lookupNBinder x; p1 <- repLP p                              ; repPaspat x' p1 }-repP (ParPat _ p)       = repLP p+repP (ParPat _ _ p _)      = repLP p repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs } repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps)                                                ; e' <- repE e@@ -2069,8 +2066,8 @@    }  where    rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat)))-   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)-                          ; MkC p <- repLP (hsRecFieldArg fld)+   rep_fld (L _ fld) = do { MkC v <- lookupOcc (hsRecFieldSel fld)+                          ; MkC p <- repLP (hfbRHS fld)                           ; rep2 fieldPatName [v,p] } repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l                                      ; repPlit a }@@ -2172,7 +2169,7 @@         ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))         ; rep2_nwDsM mkNameLName [occ,uni] }   where-      mod = ASSERT( isExternalName name) nameModule name+      mod = assert (isExternalName name) nameModule name       name_mod = moduleNameString (moduleName mod)       name_pkg = unitString (moduleUnit mod)       name_occ = nameOccName name@@ -2707,7 +2704,7 @@       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)        rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))-      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)+      rep_one_ip t n = do { MkC v  <- lookupOcc (foExt $ unLoc n)                           ; MkC ty <- repBangTy  t                           ; rep2 varBangTypeName [v,ty] }
compiler/GHC/HsToCore/Usage.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.HsToCore.Usage (@@ -7,8 +7,6 @@     mkUsageInfo, mkUsedNames, mkDependencies     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -40,11 +38,12 @@ import GHC.Data.Maybe  import Control.Monad (filterM)-import Data.List (sort, sortBy, nub)+import Data.List (sortBy, sort, nub) import Data.IORef import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set+ import System.Directory import System.FilePath @@ -82,8 +81,7 @@       let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]           plugin_dep_pkgs = filter (/= iuid) (map (toUnitId . moduleUnit) ms)       th_used <- readIORef th_var-      let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)-                                             (moduleName mod))+      let direct_mods = modDepsElts (delFromUFM (imp_direct_dep_mods imports) (moduleName mod))                 -- M.hi-boot can be in the imp_dep_mods, but we must remove                 -- it before recording the modules on which this one depends!                 -- (We want to retain M.hi-boot in imp_dep_mods so that@@ -95,19 +93,28 @@                 -- We must also remove self-references from imp_orphs. See                 -- Note [Module self-dependency] -          raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs+          direct_pkgs_0 = foldr Set.insert (imp_dep_direct_pkgs imports) plugin_dep_pkgs -          pkgs | th_used   = Set.insert thUnitId raw_pkgs-               | otherwise = raw_pkgs+          direct_pkgs+            | th_used = Set.insert thUnitId direct_pkgs_0+            | otherwise = direct_pkgs_0            -- Set the packages required to be Safe according to Safe Haskell.           -- See Note [Tracking Trust Transitively] in GHC.Rename.Names-          sorted_pkgs = sort (Set.toList pkgs)+          sorted_direct_pkgs = sort (Set.toList direct_pkgs)           trust_pkgs  = imp_trust_pkgs imports-          dep_pkgs'   = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs+          -- If there's a non-boot import, then it shadows the boot import+          -- coming from the dependencies+          source_mods =+            modDepsElts $ (imp_boot_mods imports) -      return Deps { dep_mods   = dep_mods,-                    dep_pkgs   = dep_pkgs',+          sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports++      return Deps { dep_direct_mods = direct_mods,+                    dep_direct_pkgs = sorted_direct_pkgs,+                    dep_sig_mods = sort sig_mods,+                    dep_trusted_pkgs = sort (Set.toList trust_pkgs),+                    dep_boot_mods  = sort source_mods,                     dep_orphs  = dep_orphs,                     dep_plgins = dep_plgins,                     dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }@@ -237,7 +244,7 @@     pNm      = moduleName $ mi_module pluginModule     pPkg     = moduleUnit $ mi_module pluginModule     deps     = map gwib_mod $-      dep_mods $ mi_deps pluginModule+      dep_direct_mods $ mi_deps pluginModule      -- Lookup object file for a plugin dependency,     -- from the same package as the plugin.@@ -289,7 +296,7 @@         | isWiredInName name = mv_map  -- ignore wired-in names         | otherwise         = case nameModule_maybe name of-             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map+             Nothing  -> assertPpr (isSystemName name) (ppr name) mv_map                 -- See Note [Internal used_names]               Just mod ->
compiler/GHC/HsToCore/Utils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-}@@ -45,8 +45,6 @@         isTrueLHsExpr     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )@@ -78,6 +76,7 @@ import GHC.Types.Name( isInternalName ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc@@ -135,7 +134,7 @@ -- Postcondition: the returned Id has an Internal Name selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat) selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat)-selectMatchVar w (ParPat _ pat)  = selectMatchVar w (unLoc pat)+selectMatchVar w (ParPat _ _ pat _) = selectMatchVar w (unLoc pat) selectMatchVar _w (VarPat _ var)  = return (localiseId (unLoc var))                                   -- Note [Localise pattern binders]                                   --@@ -144,7 +143,7 @@                                   -- multiplicity stored within the variable                                   -- itself. It's easier to pull it from the                                   -- variable, so we ignore the multiplicity.-selectMatchVar _w (AsPat _ var _) = ASSERT( isManyDataConTy _w ) (return (unLoc var))+selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var)) selectMatchVar w other_pat     = newSysLocalDsNoLP w (hsPatType other_pat)  {- Note [Localise pattern binders]@@ -198,7 +197,7 @@ -}  firstPat :: EquationInfo -> Pat GhcTc-firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)+firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)  shiftEqns :: Functor f => f EquationInfo -> f EquationInfo -- Drop the first pattern in each equation@@ -283,7 +282,7 @@      sorted_alts = sortWith fst match_alts       -- Right order for a Case     mk_alt fail (lit, mr)-       = ASSERT( not (litIsLifted lit) )+       = assert (not (litIsLifted lit)) $          do body <- runMatchResult fail mr             return (Alt (LitAlt lit) [] body) @@ -299,7 +298,7 @@   -> MatchResult CoreExpr mkCoAlgCaseMatchResult var ty match_alts   | isNewtype  -- Newtype case; use a let-  = ASSERT( null match_alts_tail && null (tail arg_ids1) )+  = assert (null match_alts_tail && null (tail arg_ids1)) $     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1    | otherwise@@ -313,7 +312,7 @@     alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail       = match_alts     -- Stuff for newtype-    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1+    arg_id1       = assert (notNull arg_ids1) $ head arg_ids1     var_ty        = idType var     (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes                                                 -- (not that splitTyConApp does, these days)@@ -785,7 +784,7 @@  strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens-strip_bangs (L _ (ParPat _ p))  = strip_bangs p+strip_bangs (L _ (ParPat _ _ p _))  = strip_bangs p strip_bangs (L _ (BangPat _ p)) = strip_bangs p strip_bangs lp                  = lp @@ -793,7 +792,7 @@ is_flat_prod_lpat = is_flat_prod_pat . unLoc  is_flat_prod_pat :: Pat GhcTc -> Bool-is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p+is_flat_prod_pat (ParPat _ _ p _)      = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps is_flat_prod_pat (ConPat { pat_con  = L _ pcon                          , pat_args = ps})@@ -808,7 +807,7 @@ is_triv_pat :: Pat (GhcPass p) -> Bool is_triv_pat (VarPat {})  = True is_triv_pat (WildPat{})  = True-is_triv_pat (ParPat _ p) = is_triv_lpat p+is_triv_pat (ParPat _ _ p _) = is_triv_lpat p is_triv_pat _            = False  @@ -1058,7 +1057,7 @@   where     go lp@(L l p)       = case p of-           ParPat x p    -> L l (ParPat x (go p))+           ParPat x lpar p rpar -> L l (ParPat x lpar (go p) rpar)            LazyPat _ lp' -> lp'            BangPat _ _   -> lp            _             -> L l (BangPat noExtField lp)@@ -1076,7 +1075,7 @@      || v `hasKey` getUnique trueDataConId                                               = Just return         -- trueDataConId doesn't have the same unique as trueDataCon-isTrueLHsExpr (L _ (HsConLikeOut _ con))+isTrueLHsExpr (L _ (XExpr (ConLikeTc con _ _)))   | con `hasKey` getUnique trueDataCon = Just return isTrueLHsExpr (L _ (HsTick _ tickish e))     | Just ticks <- isTrueLHsExpr e@@ -1090,5 +1089,5 @@                      this_mod <- getModule                      return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (L _ (HsPar _ e))   = isTrueLHsExpr e-isTrueLHsExpr _                   = Nothing+isTrueLHsExpr (L _ (HsPar _ _ e _)) = isTrueLHsExpr e+isTrueLHsExpr _                     = Nothing
compiler/GHC/Iface/Binary.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE BinaryLiterals, ScopedTypeVariables, BangPatterns #-}  -- --  (c) The University of Glasgow 2002-2006@@ -30,8 +30,6 @@         BinDictionary(..)     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Tc.Utils.Monad@@ -51,7 +49,6 @@ import GHC.Platform import GHC.Data.FastString import GHC.Settings.Constants-import GHC.Utils.Misc  import Data.Array import Data.Array.IO@@ -300,7 +297,7 @@  serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO () serialiseName bh name _ = do-    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)     put_ bh (moduleUnit mod, moduleName mod, nameOccName name)  @@ -329,7 +326,7 @@         bh name   | isKnownKeyName name   , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits-  = -- ASSERT(u < 2^(22 :: Int))+  = -- assert (u < 2^(22 :: Int))     put_ bh (0x80000000              .|. (fromIntegral (ord c) `shiftL` 22)              .|. (fromIntegral u :: Word32))@@ -340,7 +337,7 @@          Just (off,_) -> put_ bh (fromIntegral off :: Word32)          Nothing -> do             off <- readFastMutInt symtab_next-            -- MASSERT(off < 2^(30 :: Int))+            -- massert (off < 2^(30 :: Int))             writeFastMutInt symtab_next (off+1)             writeIORef symtab_map_ref                 $! addToUFM symtab_map name (off,name)
compiler/GHC/Iface/Env.hs view
@@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2002-2006 -{-# LANGUAGE CPP, RankNTypes #-}+{-# LANGUAGE RankNTypes #-}  module GHC.Iface.Env (         newGlobalBinder, newInteractiveBinder,@@ -20,8 +20,6 @@         -- Name-cache stuff         allocateGlobalBinder,    ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Iface/Errors.hs view
@@ -18,6 +18,7 @@ import GHC.Utils.Panic.Plain import GHC.Driver.Session import GHC.Driver.Env.Types+import GHC.Driver.Errors.Types import GHC.Data.Maybe import GHC.Prelude import GHC.Unit@@ -151,7 +152,7 @@  cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $-  cantFindErr (gopt Opt_BuildingCabalPackage dflags)+  cantFindErr (checkBuildingCabalPackage dflags)               cannotFindMsg               (text "Ambiguous module name")               unit_env@@ -170,7 +171,7 @@         _ -> text "Could not find module"  cantFindErr-    :: Bool -- ^ Using Cabal?+    :: BuildingCabalPackage -- ^ Using Cabal?     -> SDoc     -> SDoc     -> UnitEnv@@ -273,7 +274,7 @@         <> dot $$ pkg_hidden_hint uid      pkg_hidden_hint uid-     | using_cabal+     | using_cabal == YesBuildingCabalPackage         = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)            in text "Perhaps you need to add" <+>               quotes (ppr (unitPackageName pkg)) <+>
compiler/GHC/Iface/Ext/Ast.hs view
@@ -19,8 +19,6 @@ Main functions for .hie file generation -} -#include "GhclibHsVersions.h"- module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where  import GHC.Utils.Outputable(ppr)@@ -57,9 +55,11 @@ import GHC.Builtin.Uniques import GHC.Iface.Make             ( mkIfaceExports ) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Data.FastString+import qualified GHC.Data.Strict as Strict  import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils@@ -175,9 +175,6 @@         [ toHie $ C Use (L mspan var)              -- Patch up var location since typechecker removes it         ]-      HsConLikeOut _ con ->-        [ toHie $ C Use $ L mspan $ conLikeName con-        ]       ...       HsApp _ a b ->         [ toHie a@@ -356,7 +353,7 @@           top_ev_asts :: [HieAST Type] <- do             let               l :: SrcSpanAnnA-              l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing)+              l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Strict.Nothing)             toHie $ EvBindContext ModuleScope Nothing                   $ L l (EvBinds ev_bs) @@ -738,7 +735,7 @@               HsLit _ l -> Just (hsLitType l)               HsOverLit _ o -> Just (overLitType o) -              HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con)+              XExpr (ConLikeTc (RealDataCon con) _ _) -> Just (dataConNonlinearType con)                HsLam     _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)               HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)@@ -775,8 +772,7 @@           skipDesugaring :: HsExpr GhcTc -> Bool           skipDesugaring e = case e of             HsVar{}             -> False-            HsConLikeOut{}      -> False-            HsRecFld{}          -> False+            HsRecSel{}          -> False             HsOverLabel{}       -> False             HsIPVar{}           -> False             XExpr (WrapExpr {}) -> False@@ -907,11 +903,11 @@             (InfixCon a b) -> combineScopes (mkLScopeN a) (mkLScopeN b)             (RecCon r) -> foldr go NoScope r           go (RecordPatSynField a b) c = combineScopes c-            $ combineScopes (mkLScopeN (rdrNameFieldOcc a)) (mkLScopeN b)+            $ combineScopes (mkLScopeN (foLabel a)) (mkLScopeN b)           detSpan = case detScope of             LocalScope a -> Just a             _ -> Nothing-          toBind (PrefixCon ts args) = ASSERT(null ts) PrefixCon ts $ map (C Use) args+          toBind (PrefixCon ts args) = assert (null ts) $ PrefixCon ts $ map (C Use) args           toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)           toBind (RecCon r) = RecCon $ map (PSC detSpan) r @@ -966,7 +962,7 @@                     lname         , toHie $ PS rsp scope pscope pat         ]-      ParPat _ pat ->+      ParPat _ _ pat _ ->         [ toHie $ PS rsp scope pscope pat         ]       BangPat _ pat ->@@ -1043,10 +1039,10 @@       contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r       contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a         where-          go :: RScoped (LocatedA (HsRecField' id a1))-                      -> LocatedA (HsRecField' id (PScoped a1)) -- AZ-          go (RS fscope (L spn (HsRecField x lbl pat pun))) =-            L spn $ HsRecField x lbl (PS rsp scope fscope pat) pun+          go :: RScoped (LocatedA (HsFieldBind id a1))+                      -> LocatedA (HsFieldBind id (PScoped a1)) -- AZ+          go (RS fscope (L spn (HsFieldBind x lbl pat pun))) =+            L spn $ HsFieldBind x lbl (PS rsp scope fscope pat) pun           scoped_fds = listScopes pscope fds  instance ToHie (TScoped (HsPatSigType GhcRn)) where@@ -1087,10 +1083,7 @@              -- Patch up var location since typechecker removes it         ]       HsUnboundVar _ _ -> []  -- there is an unbound name here, but that causes trouble-      HsConLikeOut _ con ->-        [ toHie $ C Use $ L mspan $ conLikeName con-        ]-      HsRecFld _ fld ->+      HsRecSel _ fld ->         [ toHie $ RFC RecFieldOcc Nothing (L (locA mspan) fld)         ]       HsOverLabel {} -> []@@ -1119,7 +1112,7 @@       NegApp _ a _ ->         [ toHie a         ]-      HsPar _ a ->+      HsPar _ _ a _ ->         [ toHie a         ]       SectionL _ a b ->@@ -1216,14 +1209,14 @@       HsProjection {} -> []       XExpr x         | GhcTc <- ghcPass @p-        , WrapExpr (HsWrap w a) <- x-        -> [ toHie $ L mspan a-           , toHie (L mspan w)-           ]-        | GhcTc <- ghcPass @p-        , ExpansionExpr (HsExpanded _ b) <- x-        -> [ toHie (L mspan b)-           ]+        -> case x of+             WrapExpr (HsWrap w a)+               -> [ toHie $ L mspan a+                  , toHie (L mspan w) ]+             ExpansionExpr (HsExpanded _ b)+               -> [ toHie (L mspan b) ]+             ConLikeTc con _ _+               -> [ toHie $ C Use $ L mspan $ conLikeName con ]         | otherwise -> []  -- NOTE: no longer have the location@@ -1341,12 +1334,12 @@          , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where   toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields -instance ( ToHie (RFContext (Located label))+instance ( ToHie (RFContext label)          , ToHie arg, HasLoc arg, Data arg          , Data label-         ) => ToHie (RContext (LocatedA (HsRecField' label arg))) where+         ) => ToHie (RContext (LocatedA (HsFieldBind label arg))) where   toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of-    HsRecField _ label expr _ ->+    HsFieldBind _ label expr _ ->       [ toHie $ RFC c (getRealSpan $ loc expr) label       , toHie expr       ]@@ -1422,7 +1415,7 @@       HsCmdLam _ mg ->         [ toHie mg         ]-      HsCmdPar _ a ->+      HsCmdPar _ _ a _ ->         [ toHie a         ]       HsCmdCase _ expr alts ->
compiler/GHC/Iface/Ext/Types.hs view
@@ -305,7 +305,7 @@  instance Ord NodeAnnotation where    compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1)-      = mconcat [uniqCompareFS c0 c1, uniqCompareFS t0 t1]+      = mconcat [lexicalCompareFS c0 c1, lexicalCompareFS t0 t1]  instance Outputable NodeAnnotation where    ppr (NodeAnnotation c t) = ppr (c,t)
compiler/GHC/Iface/Ext/Utils.hs view
@@ -26,6 +26,7 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Parser.Annotation+import qualified GHC.Data.Strict as Strict  import GHC.Iface.Ext.Types @@ -546,7 +547,7 @@ combineScopes NoScope x = x combineScopes x NoScope = x combineScopes (LocalScope a) (LocalScope b) =-  mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing)+  mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing)  mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
compiler/GHC/Iface/Load.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP, BangPatterns, NondecreasingIndentation #-}+{-# LANGUAGE BangPatterns, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}@@ -35,8 +35,6 @@         module Iface_Errors -- avoids boot files in Ppr modules    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.IfaceToCore@@ -64,7 +62,8 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger  import GHC.Settings.Constants@@ -165,13 +164,13 @@ -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name-  = ASSERT( not (isWiredInName name) )+  = assert (not (isWiredInName name)) $     do  { dflags <- getDynFlags         ; logger <- getLogger         ; liftIO $ trace_if logger dflags nd_doc          -- Load the interface, which should populate the PTE-        ; mb_iface <- ASSERT2( isExternalName name, ppr name )+        ; mb_iface <- assertPpr (isExternalName name) (ppr name) $                       loadInterface nd_doc (nameModule name) ImportBySystem         ; case mb_iface of {                 Failed err_msg  -> return (Failed err_msg) ;@@ -245,7 +244,7 @@         ; dflags <- getDynFlags         ; logger <- getLogger         ; liftIO $ trace_if logger dflags (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)-        ; ASSERT( isExternalName tc_name )+        ; assert (isExternalName tc_name )           when (mod /= nameModule tc_name)                (initIfaceTcRn (loadWiredInHomeIface tc_name))                 -- Don't look for (non-existent) Float.hi when@@ -268,7 +267,7 @@                 -- the HPT, so without the test we'll demand-load it into the PIT!                 -- C.f. the same test in checkWiredInTyCon above         ; let name = getName thing-        ; ASSERT2( isExternalName name, ppr name )+        ; assertPpr (isExternalName name) (ppr name) $           when (needWiredInHomeIface thing && mod /= nameModule name)                (loadWiredInHomeIface name) } @@ -348,8 +347,8 @@ loadInterfaceForName doc name   = do { when debugIsOn $  -- Check pre-condition          do { this_mod <- getModule-            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }-      ; ASSERT2( isExternalName name, ppr name )+            ; massertPpr (not (nameIsLocalOrFrom this_mod name)) (ppr name <+> parens doc) }+      ; assertPpr (isExternalName name) (ppr name) $         initIfaceTcRn $ loadSysInterface doc (nameModule name) }  -- | Only loads the interface for external non-local names.@@ -368,7 +367,7 @@     -- Should not be called with this module     when debugIsOn $ do       this_mod <- getModule-      MASSERT2( this_mod /= m, ppr m <+> parens doc )+      massertPpr (this_mod /= m) (ppr m <+> parens doc)     initIfaceTcRn $ loadSysInterface doc m  {-@@ -388,7 +387,7 @@ -- See Note [Loading instances for wired-in things] loadWiredInHomeIface :: Name -> IfM lcl () loadWiredInHomeIface name-  = ASSERT( isWiredInName name )+  = assert (isWiredInName name) $     do _ <- loadSysInterface doc (nameModule name); return ()   where     doc = text "Need home interface for wired-in thing" <+> ppr name@@ -536,7 +535,7 @@                             -- of one's own boot file! (one-shot only)                             -- See Note [Loading your own hi-boot file] -        ; WARN( bad_boot, ppr mod )+        ; warnPprTrace bad_boot (ppr mod) $           updateEps_  $ \ eps ->            if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface                 then eps@@ -692,7 +691,7 @@   -> Module   -> IO (MaybeErr SDoc (ModIface, FilePath)) computeInterface hsc_env doc_str hi_boot_file mod0 = do-  MASSERT( not (isHoleModule mod0) )+  massert (not (isHoleModule mod0))   let name_cache = hsc_NC hsc_env   let fc         = hsc_FC hsc_env   let home_unit  = hsc_home_unit hsc_env@@ -1180,18 +1179,25 @@  -- | Pretty-print unit dependencies pprDeps :: UnitState -> Dependencies -> SDoc-pprDeps unit_state (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,-                           dep_finsts = finsts })+pprDeps unit_state (Deps { dep_direct_mods = dmods+                         , dep_boot_mods = bmods+                         , dep_orphs = orphs+                         , dep_direct_pkgs = pkgs+                         , dep_trusted_pkgs = tps+                         , dep_finsts = finsts+                         , dep_plgins = plugins })   = pprWithUnitState unit_state $-    vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),-          text "package dependencies:" <+> fsep (map ppr_pkg pkgs),+    vcat [text "direct module dependencies:" <+> fsep (map ppr_mod dmods),+          text "boot module dependencies:" <+> fsep (map ppr bmods),+          text "direct package dependencies:" <+> fsep (map ppr_pkg pkgs),+          if null tps then empty else text "trusted package dependencies:" <+> fsep (map ppr_pkg pkgs),           text "orphans:" <+> fsep (map ppr orphs),+          text "plugins:" <+> fsep (map ppr plugins),           text "family instance modules:" <+> fsep (map ppr finsts)         ]   where     ppr_mod (GWIB { gwib_mod = mod_name, gwib_isBoot = boot }) = ppr mod_name <+> ppr_boot boot-    ppr_pkg (pkg,trust_req)  = ppr pkg <>-                               (if trust_req then text "*" else Outputable.empty)+    ppr_pkg pkg  = ppr pkg     ppr_boot IsBoot  = text "[boot]"     ppr_boot NotBoot = Outputable.empty
compiler/GHC/Iface/Make.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                      #-}+ {-# LANGUAGE NondecreasingIndentation #-}  {-@@ -19,8 +19,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs@@ -76,7 +74,7 @@ import GHC.Types.CompleteMatch  import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc  hiding ( eqListBy ) import GHC.Utils.Logger @@ -161,7 +159,7 @@     update_decl (IfaceId nm ty details infos)       | let not_caffy = elemNameSet nm non_cafs       , let mb_lf_info = lookupNameEnv lf_infos nm-      , WARN( isNothing mb_lf_info, text "Name without LFInfo:" <+> ppr nm ) True+      , warnPprTrace (isNothing mb_lf_info) (text "Name without LFInfo:" <+> ppr nm) True         -- Only allocate a new IfaceId if we're going to update the infos       , isJust mb_lf_info || not_caffy       = IfaceId nm ty details $@@ -646,7 +644,7 @@         (env2, if_decl) = tyConToIfaceDecl env1 tc      toIfaceClassOp (sel_id, def_meth)-        = ASSERT( sel_tyvars == binderVars tc_binders )+        = assert (sel_tyvars == binderVars tc_binders) $           IfaceClassOp (getName sel_id)                        (tidyToIfaceType env1 op_ty)                        (fmap toDmSpec def_meth)@@ -689,7 +687,7 @@                              , is_cls_nm = cls_name, is_cls = cls                              , is_tcs = rough_tcs                              , is_orphan = orph })-  = ASSERT( cls_name == className cls )+  = assert (cls_name == className cls) $     IfaceClsInst { ifDFun     = idName dfun_id                  , ifOFlag    = oflag                  , ifInstCls  = cls_name@@ -707,7 +705,7 @@                  , ifFamInstOrph     = orph }   where     fam_decl = tyConName $ coAxiomTyCon axiom-    mod = ASSERT( isExternalName (coAxiomName axiom) )+    mod = assert (isExternalName (coAxiomName axiom)) $           nameModule (coAxiomName axiom)     is_local name = nameIsLocalOrFrom mod name
compiler/GHC/Iface/Recomp.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-}  -- | Module for detecting if recompilation is required@@ -10,8 +9,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Backend@@ -36,12 +33,14 @@  import GHC.Utils.Error import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc as Utils hiding ( eqListBy ) import GHC.Utils.Binary import GHC.Utils.Fingerprint import GHC.Utils.Exception import GHC.Utils.Logger+import GHC.Utils.Constants (debugIsOn)  import GHC.Types.Annotations import GHC.Types.Name@@ -64,9 +63,8 @@  import Control.Monad import Data.Function-import Data.List (find, sortBy, sort)+import Data.List (sortBy, sort) import qualified Data.Map as Map-import qualified Data.Set as Set import Data.Word (Word64)  --Qualified import so we can define a Semigroup instance@@ -211,7 +209,31 @@                     -- even in the SourceUnmodifiedAndStable case we                     -- should check versions because some packages                     -- might have changed or gone away.-                    Just iface -> checkVersions hsc_env mod_summary iface+                    Just iface -> do+                        (recomp_reqd, mb_checked_iface) <-+                            checkVersions hsc_env mod_summary iface+                        return $ case mb_checked_iface of+                            Just iface | not (recompileRequired recomp_reqd) ->+                                -- If the module used TH splices when it was last+                                -- compiled, then the recompilation check is not+                                -- accurate enough (#481) and we must ignore+                                -- it.  However, if the module is stable (none of+                                -- the modules it depends on, directly or+                                -- indirectly, changed), then we *can* skip+                                -- recompilation. This is why the SourceModified+                                -- type contains SourceUnmodifiedAndStable, and+                                -- it's pretty important: otherwise ghc --make+                                -- would always recompile TH modules, even if+                                -- nothing at all has changed. Stability is just+                                -- the same check that make is doing for us in+                                -- one-shot mode.+                                let stable = case src_modified of+                                        SourceUnmodifiedAndStable -> True+                                        _                         -> False+                                in if mi_used_th iface && not stable+                                    then (RecompBecause "TH", mb_checked_iface)+                                    else (recomp_reqd, mb_checked_iface)+                            _ -> (recomp_reqd, mb_checked_iface)  -- | Check if a module is still the same 'version'. --@@ -266,11 +288,10 @@        -- It's just temporary because either the usage check will succeed        -- (in which case we are done with this module) or it'll fail (in which        -- case we'll compile the module from scratch anyhow).-       ---       -- We do this regardless of compilation mode, although in --make mode-       -- all the dependent modules should be in the HPT already, so it's-       -- quite redundant-       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }++       when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {+          ; updateEps_ $ \eps  -> eps { eps_is_boot = mkModDeps $ (dep_boot_mods (mi_deps iface)) }+       }        ; recomp <- checkList [checkModUsage (homeUnitAsUnit home_unit) u                              | u <- mi_usages iface]        ; return (recomp, Just iface)@@ -279,10 +300,10 @@     logger = hsc_logger hsc_env     dflags = hsc_dflags hsc_env     home_unit = hsc_home_unit hsc_env-    -- This is a bit of a hack really-    mod_deps :: ModuleNameEnv ModuleNameWithIsBoot-    mod_deps = mkModDeps (dep_mods (mi_deps iface)) +++ -- | Check if any plugins are requesting recompilation checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired checkPlugins hsc_env iface = liftIO $ do@@ -359,7 +380,7 @@ checkHsig logger home_unit dflags mod_summary iface = do     let outer_mod = ms_mod mod_summary         inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)-    MASSERT( isHomeModule home_unit outer_mod )+    massert (isHomeModule home_unit outer_mod)     case inner_mod == mi_semantic_module iface of         True -> up_to_date logger dflags (text "implementing module unchanged")         False -> return (RecompBecause "implementing module changed")@@ -451,38 +472,19 @@ --   - a new home module has been added that shadows a package module -- See bug #1372. ----- In addition, we also check if the union of dependencies of the imported--- modules has any difference to the previous set of dependencies. We would need--- to recompile in that case also since the `mi_deps` field of ModIface needs--- to be updated to match that information. This is one of the invariants--- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).--- See bug #16511.--- -- Returns (RecompBecause <textual reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface- =-   checkList $-     [ liftIO $ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))-     , do-         (recomp, mnames_seen) <- runUntilRecompRequired $ map-           checkForNewHomeDependency-           (ms_home_imps summary)-         liftIO $ case recomp of-           UpToDate -> do-             let-               seen_home_deps = Set.unions $ map Set.fromList mnames_seen-             checkIfAllOldHomeDependenciesAreSeen seen_home_deps-           _ -> return recomp]+ = liftIO $ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))  where    dflags        = hsc_dflags hsc_env    logger        = hsc_logger hsc_env    fc            = hsc_FC hsc_env    home_unit     = hsc_home_unit hsc_env    units         = hsc_units hsc_env-   prev_dep_mods = dep_mods (mi_deps iface)+   prev_dep_mods = dep_direct_mods (mi_deps iface)    prev_dep_plgn = dep_plgins (mi_deps iface)-   prev_dep_pkgs = dep_pkgs (mi_deps iface)+   prev_dep_pkgs = dep_direct_pkgs (mi_deps iface)     dep_missing (mb_pkg, L _ mod) = do      find_res <- findImportedModule fc units home_unit dflags mod (mb_pkg)@@ -498,7 +500,7 @@                  else                          return UpToDate           | otherwise-           -> if toUnitId pkg `notElem` (map fst prev_dep_pkgs)+           -> if toUnitId pkg `notElem` prev_dep_pkgs                  then do trace_hi_diffs logger dflags $                            text "imported module " <> quotes (ppr mod) <>                            text " is from package " <> quotes (ppr pkg) <>@@ -509,58 +511,6 @@            where pkg = moduleUnit mod         _otherwise  -> return (RecompBecause reason) -   projectNonBootNames = map gwib_mod . filter ((== NotBoot) . gwib_isBoot)-   old_deps = Set.fromList-     $ projectNonBootNames prev_dep_mods-   isOldHomeDeps = flip Set.member old_deps-   checkForNewHomeDependency (L _ mname) = do-     let-       mod = mkHomeModule home_unit mname-       str_mname = moduleNameString mname-       reason = str_mname ++ " changed"-     -- We only want to look at home modules to check if any new home dependency-     -- pops in and thus here, skip modules that are not home. Checking-     -- membership in old home dependencies suffice because the `dep_missing`-     -- check already verified that all imported home modules are present there.-     if not (isOldHomeDeps mname)-       then return (UpToDate, [])-       else do-         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do-           let mnames = mname:(map gwib_mod $ filter ((== NotBoot) . gwib_isBoot) $-                 dep_mods $ mi_deps imported_iface)-           case find (not . isOldHomeDeps) mnames of-             Nothing -> return (UpToDate, mnames)-             Just new_dep_mname -> do-               trace_hi_diffs logger dflags $-                 text "imported home module " <> quotes (ppr mod) <>-                 text " has a new dependency " <> quotes (ppr new_dep_mname)-               return (RecompBecause reason, [])-         return $ fromMaybe (MustCompile, []) mb_result--   -- Performs all recompilation checks in the list until a check that yields-   -- recompile required is encountered. Returns the list of the results of-   -- all UpToDate checks.-   runUntilRecompRequired []             = return (UpToDate, [])-   runUntilRecompRequired (check:checks) = do-     (recompile, value) <- check-     if recompileRequired recompile-       then return (recompile, [])-       else do-         (recomp, values) <- runUntilRecompRequired checks-         return (recomp, value:values)--   checkIfAllOldHomeDependenciesAreSeen seen_deps = do-     let unseen_old_deps = Set.difference-          old_deps-          seen_deps-     if not (null unseen_old_deps)-       then do-         let missing_dep = Set.elemAt 0 unseen_old_deps-         trace_hi_diffs logger dflags $-           text "missing old home dependency " <> quotes (ppr missing_dep)-         return $ RecompBecause "missing old dependency"-       else return UpToDate- needInterface :: Module -> (ModIface -> IO RecompileRequired)              -> IfG RecompileRequired needInterface mod continue@@ -665,12 +615,9 @@          else return UpToDate  where    recomp  = RecompBecause (file ++ " changed")-   handler =-#if defined(DEBUG)-       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp-#else-       \_ -> return recomp -- if we can't find the file, just recompile, don't fail-#endif+   handler = if debugIsOn+      then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp+      else \_ -> return recomp -- if we can't find the file, just recompile, don't fail  ------------------------ checkModuleFingerprint@@ -882,7 +829,7 @@                , let out = localOccs $ freeNamesDeclABI abi                ] -       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n+       name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n)        localOccs =          map (getUnique . getParent . getOccName)                         -- NB: names always use semantic module, so@@ -925,7 +872,7 @@           | isWiredInName name  =  putNameLiterally bh name            -- wired-in names don't have fingerprints           | otherwise-          = ASSERT2( isExternalName name, ppr name )+          = assertPpr (isExternalName name) (ppr name) $             let hash | nameModule name /= semantic_mod =  global_hash_fn name                      -- Get it from the REAL interface!!                      -- This will trigger when we compile an hsig file@@ -1047,17 +994,22 @@    orphan_hash <- computeFingerprint (mk_put_name local_env)                                      (map ifDFun orph_insts, orph_rules, orph_fis) +   -- Hash of the transitive things in dependencies+   dep_hash <- computeFingerprint putNameLiterally+                       (dep_sig_mods (mi_deps iface0),+                        dep_boot_mods (mi_deps iface0),+                        -- Trusted packages are like orphans+                        dep_trusted_pkgs (mi_deps iface0),+                       -- See Note [Export hash depends on non-orphan family instances]+                        dep_finsts (mi_deps iface0) )+    -- the export list hash doesn't depend on the fingerprints of    -- the Names it mentions, only the Names themselves, hence putNameLiterally.    export_hash <- computeFingerprint putNameLiterally                       (mi_exports iface0,                        orphan_hash,+                       dep_hash,                        dep_orphan_hashes,-                       dep_pkgs (mi_deps iface0),-                       -- See Note [Export hash depends on non-orphan family instances]-                       dep_finsts (mi_deps iface0),-                        -- dep_pkgs: see "Package Version Changes" on-                        -- wiki/commentary/compiler/recompilation-avoidance                        mi_trust iface0)                         -- Make sure change of Safe Haskell mode causes recomp. @@ -1213,8 +1165,11 @@  sortDependencies :: Dependencies -> Dependencies sortDependencies d- = Deps { dep_mods   = sortBy (lexicalCompareFS `on` (moduleNameFS . gwib_mod)) (dep_mods d),-          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),+ = Deps { dep_direct_mods = sortBy (lexicalCompareFS `on` (moduleNameFS . gwib_mod)) (dep_direct_mods d),+          dep_direct_pkgs   = sort (dep_direct_pkgs d),+          dep_sig_mods      = sort (dep_sig_mods d),+          dep_trusted_pkgs  = sort (dep_trusted_pkgs d),+          dep_boot_mods   = sort (dep_boot_mods d),           dep_orphs  = sortBy stableModuleCmp (dep_orphs d),           dep_finsts = sortBy stableModuleCmp (dep_finsts d),           dep_plgins = sortBy (lexicalCompareFS `on` moduleNameFS) (dep_plgins d) }@@ -1497,7 +1452,7 @@       occ = nameOccName name       orig_mod = nameModule name       lookup mod = do-        MASSERT2( isExternalName name, ppr name )+        massertPpr (isExternalName name) (ppr name)         iface <- case lookupIfaceByModule hpt pit mod of                   Just iface -> return iface                   Nothing ->
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -47,8 +47,12 @@         lang = (fmap fromEnum language,                 map fromEnum $ EnumSet.toList extensionFlags) +        -- avoid fingerprinting the absolute path to the directory of the source file+        -- see note [Implicit include paths]+        includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] }+         -- -I, -D and -U flags affect CPP-        cpp = ( map normalise $ flattenIncludes includePaths+        cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit             -- normalise: eliminate spurious differences due to "./foo" vs "foo"               , picPOpts dflags               , opt_P_signature dflags)
compiler/GHC/Iface/Rename.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  -- | This module implements interface renaming, which is@@ -14,8 +14,6 @@     tcRnModExports,     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -78,7 +76,7 @@     -- TODO: maybe associate this with a source location?     let msg = mkPlainErrorMsgEnvelope noSrcSpan $               TcRnUnknownMessage $-              mkPlainError doc+              mkPlainError noHints doc     writeTcRef errs_var (msg `addMessage` errs)     failM @@ -251,7 +249,8 @@     ns' <- mapM rnGreName ns     case ns' of         [] -> panic "rnAvailInfoEmpty AvailInfo"-        (rep:rest) -> ASSERT2( all ((== childModule rep) . childModule) rest, ppr rep $$ hcat (map ppr rest) ) do+        (rep:rest) -> assertPpr (all ((== childModule rep) . childModule) rest)+                                (ppr rep $$ hcat (map ppr rest)) $ do                          n' <- setNameModule (Just (childModule rep)) n                          return (AvailTC n' ns')   where@@ -376,7 +375,7 @@     iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv     let m = renameHoleModule unit_state hmap $ nameModule name     -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.-    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )+    massertPpr (iface_semantic_mod == m) (ppr iface_semantic_mod <+> ppr m)     setNameModule (Just m) name  -- Note [rnIfaceNeverExported]
compiler/GHC/Iface/Tidy.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP           #-}+ {-# LANGUAGE DeriveFunctor #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -13,8 +13,6 @@        mkBootModDetailsTc, tidyProgram    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -461,7 +459,7 @@                            cg_binds    = all_tidy_binds,                            cg_foreign  = add_spt_init_code foreign_stubs,                            cg_foreign_files = foreign_files,-                           cg_dep_pkgs = map fst $ dep_pkgs deps,+                           cg_dep_pkgs = dep_direct_pkgs deps,                            cg_hpc_info = hpc_info,                            cg_modBreaks = modBreaks,                            cg_spt_entries = spt_entries },@@ -649,7 +647,14 @@   -- See Note [Which rules to expose]   is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars -  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules+  rule_rhs_vars+    -- No rules are exposed when omit_prags is enabled see #19836+    -- imp_id_rules are the RULES in /this/ module for /imported/ Ids+    -- If omit_prags is True, these rules won't be put in the interface file.+    -- But if omit_prags is False, so imp_id_rules are in the interface file for+    -- this module, then the local-defined Ids they use must be made external.+    | omit_prags = emptyVarSet+    | otherwise = mapUnionVarSet ruleRhsFreeVars imp_id_rules    binders          = map fst $ flattenBinds binds   implicit_binders = bindersOfBinds implicit_binds@@ -701,7 +706,7 @@                 -- unfolding in the *definition*; so look up in binder_set           refined_id = case lookupVarSet binder_set idocc of                          Just id -> id-                         Nothing -> WARN( True, ppr idocc ) idocc+                         Nothing -> warnPprTrace True (ppr idocc) idocc            unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)           referrer' | isExportedId refined_id = refined_id@@ -1218,7 +1223,7 @@      sig = dmdSigInfo idinfo     final_sig | not $ isTopSig sig-              = WARN( _bottom_hidden sig , ppr name ) sig+              = warnPprTrace (_bottom_hidden sig) (ppr name) sig               -- try a cheap-and-cheerful bottom analyser               | Just (_, nsig) <- mb_bot_str = nsig               | otherwise                    = sig
compiler/GHC/IfaceToCore.hs view
@@ -6,7 +6,7 @@ Type checking of type signatures in interface files -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE NondecreasingIndentation #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -24,8 +24,6 @@         tcIfaceOneShot  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -74,6 +72,8 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger  import GHC.Data.Bag@@ -1291,13 +1291,23 @@ tcIfaceCompleteMatches = mapM tcIfaceCompleteMatch  tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch-tcIfaceCompleteMatch (IfaceCompleteMatch ms mtc) = do-  conlikes <- mkUniqDSet <$> mapM (forkM doc . tcIfaceConLike) ms+tcIfaceCompleteMatch (IfaceCompleteMatch ms mtc) = forkM doc $ do -- See Note [Positioning of forkM]+  conlikes <- mkUniqDSet <$> mapM tcIfaceConLike ms   mtc' <- traverse tcIfaceTyCon mtc   return (CompleteMatch conlikes mtc')   where     doc = text "COMPLETE sig" <+> ppr ms +{- Note [Positioning of forkM]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to be lazy when type checking the interface, since these functions are+called when the interface itself is being loaded, which means it is not in the+PIT yet. In particular, the `tcIfaceTCon` must be inside the forkM, otherwise+we'll try to look it up the TyCon, find it's not there, and so initiate the+process (again) of loading the (very same) interface file. Result: infinite+loop. See #19744.+-}+ {- ************************************************************************ *                                                                      *@@ -1418,6 +1428,7 @@ tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str+tcIfaceUnivCoProv (IfaceCorePrepProv b)     = return $ CorePrepProv b  {- ************************************************************************@@ -1556,12 +1567,12 @@            -> IfaceAlt            -> IfL CoreAlt tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs)-  = ASSERT( null names ) do+  = assert (null names) $ do     rhs' <- tcIfaceExpr rhs     return (Alt DEFAULT [] rhs')  tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs)-  = ASSERT( null names ) do+  = assert (null names) $ do     lit' <- tcIfaceLit lit     rhs' <- tcIfaceExpr rhs     return (Alt (LitAlt lit') [] rhs')
compiler/GHC/Linker/Dynamic.hs view
@@ -8,8 +8,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.Platform.Ways
compiler/GHC/Linker/Loader.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, TupleSections, RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections, RecordWildCards #-} {-# LANGUAGE BangPatterns #-}  --@@ -31,8 +32,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Settings@@ -67,6 +66,8 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (isWindowsHost, isDarwinHost) import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Logger@@ -180,7 +181,7 @@      case lookupNameEnv (closure_env pls) name of       Just (_,aa) -> return (pls,aa)-      Nothing     -> ASSERT2(isExternalName name, ppr name)+      Nothing     -> assertPpr (isExternalName name) (ppr name) $                      do let sym_to_find = nameToCLabel name "closure"                         m <- lookupClosure interp (unpackFS sym_to_find)                         r <- case m of@@ -691,20 +692,20 @@             deps  = mi_deps iface             home_unit = hsc_home_unit hsc_env -            pkg_deps = dep_pkgs deps-            (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $+            pkg_deps = dep_direct_pkgs deps+            (boot_deps, mod_deps) = flip partitionWith (dep_direct_mods deps) $               \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) ->                 m & case is_boot of                   IsBoot -> Left                   NotBoot -> Right -            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps+            mod_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) (boot_deps ++ mod_deps)             acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)-            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps+            acc_pkgs'  = addListToUniqDSet acc_pkgs pkg_deps           --           if not (isHomeUnit home_unit pkg)              then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))-             else follow_deps (map (mkHomeModule home_unit) boot_deps' ++ mods)+             else follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods)                               acc_mods' acc_pkgs'         where             msg = text "need to link module" <+> ppr mod <+>@@ -757,7 +758,7 @@                         return lnk              adjust_ul new_osuf (DotO file) = do-                MASSERT(osuf `isSuffixOf` file)+                massert (osuf `isSuffixOf` file)                 let file_base = fromJust (stripExtension osuf file)                     new_file = file_base <.> new_osuf                 ok <- doesFileExist new_file@@ -1169,9 +1170,6 @@   where     unloadObjs :: Linkable -> IO ()     unloadObjs lnk-        -- The RTS's PEi386 linker currently doesn't support unloading.-      | isWindowsHost = return ()-       | hostIsDynamic = return ()         -- We don't do any cleanup when linking objects with the         -- dynamic linker.  Doing so introduces extra complexity for
compiler/GHC/Llvm/Ppr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-}  --------------------------------------------------------------------------------@@ -29,8 +29,6 @@     ppPlainName      ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Llvm/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP        #-}+ {-# LANGUAGE LambdaCase #-}  --------------------------------------------------------------------------------@@ -6,8 +6,6 @@ --  module GHC.Llvm.Types where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Rename/Bind.hs view
@@ -18,7 +18,7 @@  module GHC.Rename.Bind (    -- Renaming top-level bindings-   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,+   rnTopBindsLHS, rnTopBindsLHSBoot, rnTopBindsBoot, rnValBindsRHS,     -- Renaming local bindings    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,@@ -35,6 +35,7 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts )  import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Rename.HsType import GHC.Rename.Pat@@ -187,13 +188,24 @@ rnTopBindsLHS fix_env binds   = rnValBindsLHS (topRecNameMaker fix_env) binds +-- Ensure that a hs-boot file has no top-level bindings.+rnTopBindsLHSBoot :: MiniFixityEnv+                  -> HsValBinds GhcPs+                  -> RnM (HsValBindsLR GhcRn GhcPs)+rnTopBindsLHSBoot fix_env binds+  = do  { topBinds <- rnTopBindsLHS fix_env binds+        ; case topBinds of+            ValBinds x mbinds sigs ->+              do  { mapM_ bindInHsBootFileErr mbinds+                  ; pure (ValBinds x emptyBag sigs) }+            _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) }+ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs                -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures-rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)-  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)-        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs+rnTopBindsBoot bound_names (ValBinds _ _ sigs)+  = do  { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs         ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) @@ -431,7 +443,8 @@ rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })   | isTopRecNameMaker name_maker   = do { addLocMA checkConName rdrname-       ; name <- lookupLocatedTopBndrRnN rdrname -- Should be in scope already+       ; name <-+           lookupLocatedTopConstructorRnN rdrname -- Should be in scope already        ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }    | otherwise  -- Pattern synonym, not at top level@@ -489,8 +502,7 @@         -- See Note [Pattern bindings that bind no variables]         ; whenWOptM Opt_WarnUnusedPatternBinds $           when (null bndrs && not ok_nobind_pat) $-          addDiagnostic (WarningWithFlag Opt_WarnUnusedPatternBinds) $-          unusedPatBindWarn bind'+          addTcRnDiagnostic (TcRnUnusedPatternBinds bind')          ; fvs' `seq` -- See Note [Free-variable space leak]           return (bind', bndrs, all_fvs) }@@ -694,7 +706,7 @@                       ; return ( (pat', InfixCon name1 name2)                                , mkFVs (map unLoc [name1, name2])) }                RecCon vars ->-                   do { checkDupRdrNames (map (rdrNameFieldOcc . recordPatSynField) vars)+                   do { checkDupRdrNames (map (foLabel . recordPatSynField) vars)                       ; fls <- lookupConstructorFields name                       ; let fld_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]                       ; let rnRecordPatSynField@@ -730,7 +742,7 @@                           , psb_ext = fvs' }               selector_names = case details' of                                  RecCon names ->-                                  map (extFieldOcc . recordPatSynField) names+                                  map (foExt . recordPatSynField) names                                  _ -> []          ; fvs' `seq` -- See Note [Free-variable space leak]@@ -1322,10 +1334,10 @@                               2 (ppr sig)                          , text "Use DefaultSignatures to enable default signatures" ] -bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc-bindsInHsBootFile mbinds-  = hang (text "Bindings in hs-boot files are not allowed")-       2 (ppr mbinds)+bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM ()+bindInHsBootFileErr (L loc _)+  = addErrAt (locA loc) $+      vcat [ text "Bindings in hs-boot files are not allowed" ]  nonStdGuardErr :: (Outputable body,                    Anno (Stmt GhcRn body) ~ SrcSpanAnnA)@@ -1333,11 +1345,6 @@ nonStdGuardErr guards   = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")        4 (interpp'SP guards)--unusedPatBindWarn :: HsBind GhcRn -> SDoc-unusedPatBindWarn bind-  = hang (text "This pattern-binding binds no variables:")-       2 (ppr bind)  dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _)
compiler/GHC/Rename/Env.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} @@ -13,8 +13,11 @@         newTopSrcBinder,          lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn,+        lookupLocatedTopConstructorRn, lookupLocatedTopConstructorRnN, -        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,+        lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField,+        lookupLocatedOccRnNone,+        lookupOccRn, lookupOccRn_maybe,         lookupLocalOccRn_maybe, lookupInfoOccRn,         lookupLocalOccThLvl_maybe, lookupLocalOccRn,         lookupTypeOccRn,@@ -55,8 +58,6 @@      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Iface.Load   ( loadInterfaceForName, loadSrcInterface_maybe )@@ -252,7 +253,7 @@  -- Can be made to not be exposed -- Only used unwrapped in rnAnnProvenance-lookupTopBndrRn :: RdrName -> RnM Name+lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name -- Look up a top-level source-code binder.   We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. -- For example, this is OK:@@ -263,7 +264,7 @@ -- -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one.-lookupTopBndrRn rdr_name =+lookupTopBndrRn which_suggest rdr_name =   lookupExactOrOrig rdr_name id $     do  {  -- Check for operators in type or class declarations            -- See Note [Type and class operator definitions]@@ -277,14 +278,20 @@             [gre] -> return (greMangledName gre)             _     -> do -- Ambiguous (can't happen) or unbound                         traceRn "lookupTopBndrRN fail" (ppr rdr_name)-                        unboundName WL_LocalTop rdr_name+                        unboundName (LF which_suggest WL_LocalTop) rdr_name     } +lookupLocatedTopConstructorRn :: Located RdrName -> RnM (Located Name)+lookupLocatedTopConstructorRn = wrapLocM (lookupTopBndrRn WL_Constructor)++lookupLocatedTopConstructorRnN :: LocatedN RdrName -> RnM (LocatedN Name)+lookupLocatedTopConstructorRnN = wrapLocMA (lookupTopBndrRn WL_Constructor)+ lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)-lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn+lookupLocatedTopBndrRn = wrapLocM (lookupTopBndrRn WL_Anything)  lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name)-lookupLocatedTopBndrRnN = wrapLocMA lookupTopBndrRn+lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything)  -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see@@ -395,7 +402,7 @@ lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f GHC.Rename.Bind.rnMethodBind   = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*-  = lookupLocatedOccRn tc_rdr+  = lookupLocatedOccRnConstr tc_rdr  ----------------------------------------------- lookupConstructorFields :: Name -> RnM [FieldLabel]@@ -552,7 +559,8 @@                                   Nothing -> unbound           | otherwise   -> unbound   where-    unbound = UnambiguousGre . NormalGreName <$> unboundName WL_Global rdr_name+    unbound = UnambiguousGre . NormalGreName+          <$> unboundName (LF WL_RecField WL_Global) rdr_name   {- Note [DisambiguateRecordFields]@@ -993,6 +1001,18 @@                    -> TcRn (GenLocated (SrcSpanAnn' ann) Name) lookupLocatedOccRn = wrapLocMA lookupOccRn +lookupLocatedOccRnConstr :: GenLocated (SrcSpanAnn' ann) RdrName+                         -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr++lookupLocatedOccRnRecField :: GenLocated (SrcSpanAnn' ann) RdrName+                           -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField++lookupLocatedOccRnNone :: GenLocated (SrcSpanAnn' ann) RdrName+                       -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone+ lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Just look in the local environment lookupLocalOccRn_maybe rdr_name@@ -1005,14 +1025,35 @@   = do { lcl_env <- getLclEnv        ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } --- lookupOccRn looks up an occurrence of a RdrName-lookupOccRn :: RdrName -> RnM Name-lookupOccRn rdr_name+-- lookupOccRn' looks up an occurrence of a RdrName, and uses its argument to+-- determine what kind of suggestions should be displayed if it is not in scope+lookupOccRn' :: WhatLooking -> RdrName -> RnM Name+lookupOccRn' which_suggest rdr_name   = do { mb_name <- lookupOccRn_maybe rdr_name        ; case mb_name of            Just name -> return name-           Nothing   -> reportUnboundName rdr_name }+           Nothing   -> reportUnboundName' which_suggest rdr_name } +-- lookupOccRn looks up an occurrence of a RdrName and displays suggestions if+-- it is not in scope+lookupOccRn :: RdrName -> RnM Name+lookupOccRn = lookupOccRn' WL_Anything++-- lookupOccRnConstr looks up an occurrence of a RdrName and displays+-- constructors and pattern synonyms as suggestions if it is not in scope+lookupOccRnConstr :: RdrName -> RnM Name+lookupOccRnConstr = lookupOccRn' WL_Constructor++-- lookupOccRnRecField looks up an occurrence of a RdrName and displays+-- record fields as suggestions if it is not in scope+lookupOccRnRecField :: RdrName -> RnM Name+lookupOccRnRecField = lookupOccRn' WL_RecField++-- lookupOccRnRecField looks up an occurrence of a RdrName and displays+-- no suggestions if it is not in scope+lookupOccRnNone :: RdrName -> RnM Name+lookupOccRnNone = lookupOccRn' WL_None+ -- Only used in one place, to rename pattern synonym binders. -- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind lookupLocalOccRn :: RdrName -> RnM Name@@ -1020,7 +1061,7 @@   = do { mb_name <- lookupLocalOccRn_maybe rdr_name        ; case mb_name of            Just name -> return name-           Nothing   -> unboundName WL_LocalOnly rdr_name }+           Nothing   -> unboundName (LF WL_Anything WL_LocalOnly) rdr_name }  -- lookupTypeOccRn looks up an optionally promoted RdrName. -- Used for looking up type variables.@@ -1045,7 +1086,7 @@        ; if data_kinds             then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr                     ; case mb_demoted_name of-                        Nothing -> unboundNameX WL_Any rdr_name star_info+                        Nothing -> unboundNameX looking_for rdr_name star_info                         Just demoted_name ->                           do { addDiagnostic                                  (WarningWithFlag Opt_WarnUntickedPromotedConstructors)@@ -1059,12 +1100,13 @@                                          lookupOccRn_maybe demoted_rdr                     ; let suggestion | isJust mb_demoted_name = suggest_dk                                      | otherwise = star_info-                    ; unboundNameX WL_Any rdr_name suggestion } }+                    ; unboundNameX looking_for rdr_name suggestion } }    | otherwise-  = reportUnboundName rdr_name+  = reportUnboundName' (lf_which looking_for) rdr_name    where+    looking_for = LF WL_Constructor WL_Anywhere     suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"     untickedPromConstrWarn name =       text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot@@ -1157,21 +1199,17 @@ -- -- This may be a local variable, global variable, or one or more record selector -- functions.  It will not return record fields created with the--- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]).  The--- 'DuplicateRecordFields' argument controls whether ambiguous fields will be--- allowed (resulting in an 'AmbiguousFields' result being returned).+-- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]). -- -- If the name is not in scope at the term level, but its promoted equivalent is -- in scope at the type level, the lookup will succeed (so that the type-checker -- can report a more informative error later).  See Note [Promotion]. ---lookupExprOccRn-  :: DuplicateRecordFields -> RdrName-  -> RnM (Maybe AmbiguousResult)-lookupExprOccRn dup_fields_ok rdr_name-  = do { mb_name <- lookupOccRnX_maybe global_lookup (UnambiguousGre . NormalGreName) rdr_name+lookupExprOccRn :: RdrName -> RnM (Maybe GreName)+lookupExprOccRn rdr_name+  = do { mb_name <- lookupOccRnX_maybe global_lookup NormalGreName rdr_name        ; case mb_name of-           Nothing   -> fmap @Maybe (UnambiguousGre . NormalGreName) <$> lookup_promoted rdr_name+           Nothing   -> fmap @Maybe NormalGreName <$> lookup_promoted rdr_name                         -- See Note [Promotion].                         -- We try looking up the name as a                         -- type constructor or type variable, if@@ -1179,8 +1217,14 @@            p         -> return p }    where-    global_lookup :: RdrName -> RnM (Maybe AmbiguousResult)-    global_lookup = lookupGlobalOccRn_overloaded dup_fields_ok WantNormal+    global_lookup :: RdrName -> RnM (Maybe GreName)+    global_lookup  rdr_name =+      do { mb_name <- lookupGlobalOccRn_overloaded NoDuplicateRecordFields WantNormal rdr_name+         ; case mb_name of+             Just (UnambiguousGre name) -> return (Just name)+             Just _ -> panic "GHC.Rename.Env.global_lookup: The impossible happened!"+             Nothing -> return Nothing+         }  lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Looks up a RdrName occurrence in the top-level@@ -1210,7 +1254,11 @@     case mn of       Just n -> return n       Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)-                    ; unboundName WL_Global rdr_name }+                    ; unboundName (LF which_suggest WL_Global) rdr_name }+        where which_suggest = case fos of+                WantNormal -> WL_Anything+                WantBoth   -> WL_RecField+                WantField  -> WL_RecField  -- Looks up a RdrName occurrence in the GlobalRdrEnv and with -- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first.@@ -1446,7 +1494,7 @@         GreNotFound ->           do             traceRn "lookupGreAvailRn" (ppr rdr_name)-            name <- unboundName WL_Global rdr_name+            name <- unboundName (LF WL_Anything WL_Global) rdr_name             return (name, avail name)         MultipleNames gres ->           do@@ -1530,7 +1578,7 @@   where     occ = greOccName gre     name = greMangledName gre-    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    name_mod = assertPpr (isExternalName name) (ppr name) (nameModule name)     doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"      mk_msg imp_spec txt@@ -1813,11 +1861,12 @@      lookup_top keep_me       = do { env <- getGlobalRdrEnv+           ; dflags <- getDynFlags            ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)                  names_in_scope = -- If rdr_name lacks a binding, only                                   -- recommend alternatives from related                                   -- namespaces. See #17593.-                                  filter (\n -> nameSpacesRelated+                                  filter (\n -> nameSpacesRelated dflags WL_Anything                                                   (rdrNameSpace rdr_name)                                                   (nameNameSpace n))                                 $ map greMangledName@@ -1976,7 +2025,7 @@   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if not rebindable_on          then return Nothing-         else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))+         else do { ite <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse"))                  ; return (Just ite) } }  lookupSyntaxName :: Name                 -- ^ The standard name@@ -1991,7 +2040,7 @@   = do { rebind <- xoptM LangExt.RebindableSyntax        ; if not rebind          then return (std_name, emptyFVs)-         else do { nm <- lookupOccRn (mkRdrUnqual (nameOccName std_name))+         else do { nm <- lookupOccRnNone (mkRdrUnqual (nameOccName std_name))                  ; return (nm, unitFV nm) } }  lookupSyntaxExpr :: Name                          -- ^ The standard name@@ -2015,7 +2064,8 @@        ; if not rebindable_on then              return (map (HsVar noExtField . noLocA) std_names, emptyFVs)         else-          do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names+          do { usr_names <-+                 mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names              ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } }  @@ -2049,7 +2099,7 @@  lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) lookupNameWithQualifier std_name modName-  = do { qname <- lookupOccRn (mkRdrQual modName (nameOccName std_name))+  = do { qname <- lookupOccRnNone (mkRdrQual modName (nameOccName std_name))        ; return (qname, unitFV qname) }  -- See Note [QualifiedDo].
compiler/GHC/Rename/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ConstraintKinds     #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE MultiWayIf          #-}@@ -25,8 +25,6 @@         AnnoBody    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS@@ -61,6 +59,7 @@ import GHC.Data.List.SetOps ( removeDups ) import GHC.Utils.Error import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc import GHC.Data.FastString@@ -212,12 +211,11 @@  rnExpr (HsVar _ (L l v))   = do { dflags <- getDynFlags-       ; let dup_fields_ok = xopt_DuplicateRecordFields dflags-       ; mb_name <- lookupExprOccRn dup_fields_ok v+       ; mb_name <- lookupExprOccRn v         ; case mb_name of {            Nothing -> rnUnboundVar v ;-           Just (UnambiguousGre (NormalGreName name))+           Just (NormalGreName name)               | name == nilDataConName -- Treat [] as an ExplicitList, so that                                        -- OverloadedLists works correctly                                        -- Note [Empty lists] in GHC.Hs.Expr@@ -226,12 +224,11 @@                | otherwise               -> finishHsVar (L (na2la l) name) ;-            Just (UnambiguousGre (FieldGreName fl)) ->+            Just (FieldGreName fl) ->               let sel_name = flSelector fl in-              return ( HsRecFld noExtField (Unambiguous sel_name (L l v) ), unitFV sel_name) ;-            Just AmbiguousFields ->-              return ( HsRecFld noExtField (Ambiguous noExtField (L l v) ), emptyFVs) } }-+              return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name) ;+         }+       }  rnExpr (HsIPVar x v)   = return (HsIPVar x v, emptyFVs)@@ -293,7 +290,7 @@         -- should prevent bad things happening.         ; fixity <- case op' of               L _ (HsVar _ (L _ n)) -> lookupFixityRn n-              L _ (HsRecFld _ f)    -> lookupFieldFixityRn f+              L _ (HsRecSel _ f)    -> lookupFieldFixityRn f               _ -> return (Fixity NoSourceText minPrecedence InfixL)                    -- c.f. lookupFixity for unbound @@ -312,19 +309,19 @@ rnExpr (HsGetField _ e f)  = do { (getField, fv_getField) <- lookupSyntaxName getFieldName       ; (e, fv_e) <- rnLExpr e-      ; let f' = rnHsFieldLabel f+      ; let f' = rnDotFieldOcc f       ; return ( mkExpandedExpr                    (HsGetField noExtField e f')-                   (mkGetField getField e (fmap (unLoc . hflLabel) f'))+                   (mkGetField getField e (fmap (unLoc . dfoLabel) f'))                , fv_e `plusFV` fv_getField ) }  rnExpr (HsProjection _ fs)   = do { (getField, fv_getField) <- lookupSyntaxName getFieldName        ; circ <- lookupOccRn compose_RDR-       ; let fs' = fmap rnHsFieldLabel fs+       ; let fs' = fmap rnDotFieldOcc fs        ; return ( mkExpandedExpr                     (HsProjection noExtField fs')-                    (mkProjection getField circ (map (fmap (unLoc . hflLabel)) fs'))+                    (mkProjection getField circ (map (fmap (unLoc . dfoLabel)) fs'))                 , unitFV circ `plusFV` fv_getField) }  ------------------------------------------@@ -336,17 +333,17 @@ --------------------------------------------- --      Sections -- See Note [Parsing sections] in GHC.Parser-rnExpr (HsPar x (L loc (section@(SectionL {}))))+rnExpr (HsPar x lpar (L loc (section@(SectionL {}))) rpar)   = do  { (section', fvs) <- rnSection section-        ; return (HsPar x (L loc section'), fvs) }+        ; return (HsPar x lpar (L loc section') rpar, fvs) } -rnExpr (HsPar x (L loc (section@(SectionR {}))))+rnExpr (HsPar x lpar (L loc (section@(SectionR {}))) rpar)   = do  { (section', fvs) <- rnSection section-        ; return (HsPar x (L loc section'), fvs) }+        ; return (HsPar x lpar (L loc section') rpar, fvs) } -rnExpr (HsPar x e)+rnExpr (HsPar x lpar e rpar)   = do  { (e', fvs_e) <- rnLExpr e-        ; return (HsPar x e', fvs_e) }+        ; return (HsPar x lpar e' rpar, fvs_e) }  rnExpr expr@(SectionL {})   = do  { addErr (sectionErr expr); rnSection expr }@@ -416,7 +413,7 @@  rnExpr (RecordCon { rcon_con = con_id                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })-  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds        ; (flds', fvss) <- mapAndUnzipM rn_field flds        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }@@ -425,8 +422,8 @@                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }   where     mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n)-    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)-                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld)+                            ; return (L l (fld { hfbRHS = arg' }), fvs) }  rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })   = case rbinds of@@ -438,7 +435,7 @@       Right flds ->  -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring.         do { ; unlessXOptM LangExt.RebindableSyntax $                  addErr $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."-             ; let punnedFields = [fld | (L _ fld) <- flds, hsRecPun fld]+             ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld]              ; punsEnabled <-xoptM LangExt.RecordPuns              ; unless (null punnedFields || punsEnabled) $                  addErr $ text "For this to work enable NamedFieldPuns."@@ -705,11 +702,11 @@ ************************************************************************ -} -rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)-rnHsFieldLabel (L l (HsFieldLabel x label)) = L l (HsFieldLabel x label)+rnDotFieldOcc :: Located (DotFieldOcc GhcPs) -> Located (DotFieldOcc GhcRn)+rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)  rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn-rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnHsFieldLabel fls)+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)  {- ************************************************************************@@ -786,9 +783,9 @@   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches        ; return (HsCmdLam noExtField matches', fvMatch) } -rnCmd (HsCmdPar x e)+rnCmd (HsCmdPar x lpar e rpar)   = do  { (e', fvs_e) <- rnLCmd e-        ; return (HsCmdPar x e', fvs_e) }+        ; return (HsCmdPar x lpar e' rpar, fvs_e) }  rnCmd (HsCmdCase _ expr matches)   = do { (new_expr, e_fvs) <- rnLExpr expr@@ -838,7 +835,7 @@   = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c+methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c  methodNamesCmd (HsCmdIf _ _ _ c1 c2)   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName@@ -1670,7 +1667,7 @@  segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later-  = ASSERT( not (null ss) )+  = assert (not (null ss))     (new_stmt : later_stmts, later_uses `plusFV` uses)   where     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later@@ -1903,8 +1900,8 @@ -- using dynamic programming.  /O(n^3)/ mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree mkStmtTreeOptimal stmts =-  ASSERT(not (null stmts)) -- the empty case is handled by the caller;-                           -- we don't support empty StmtTrees.+  assert (not (null stmts)) $ -- the empty case is handled by the caller;+                              -- we don't support empty StmtTrees.   fst (arr ! (0,n))   where     n = length stmts - 1@@ -2148,7 +2145,7 @@     VarPat{}        -> False     LazyPat{}       -> False     AsPat _ _ p     -> isStrictPattern p-    ParPat _ p      -> isStrictPattern p+    ParPat _ _ p _  -> isStrictPattern p     ViewPat _ _ p   -> isStrictPattern p     SigPat _ p _    -> isStrictPattern p     BangPat{}       -> True@@ -2282,13 +2279,13 @@ isReturnApp :: MonadNames             -> LHsExpr GhcRn             -> Maybe (LHsExpr GhcRn, Bool)-isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr+isReturnApp monad_names (L _ (HsPar _ _ expr _)) = isReturnApp monad_names expr isReturnApp monad_names (L _ e) = case e of   OpApp _ l op r | is_return l, is_dollar op -> Just (r, True)   HsApp _ f arg  | is_return f               -> Just (arg, False)   _otherwise -> Nothing  where-  is_var f (L _ (HsPar _ e)) = is_var f e+  is_var f (L _ (HsPar _ _ e _)) = is_var f e   is_var f (L _ (HsAppType _ e _)) = is_var f e   is_var f (L _ (HsVar _ (L _ r))) = f r        -- TODO: I don't know how to get this right for rebindable syntax@@ -2619,9 +2616,9 @@ -- e.g. Suppose an update like foo.bar = 1. --      We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1). mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)-mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds')), hsRecFieldArg = arg } ))+mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))   = let {-      ; flds = map (fmap (unLoc . hflLabel)) flds'+      ; flds = map (fmap (unLoc . dfoLabel)) flds'       ; final = last flds  -- quux       ; fields = init flds   -- [foo, bar, baz]       ; getters = \a -> foldl' (mkGet get_field) [a] fields  -- Ordered from deep to shallow.@@ -2644,9 +2641,11 @@   pure (u, plusFVs fvs)   where     rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)-    rnRecUpdProj (L l (HsRecField _ fs arg pun))+    rnRecUpdProj (L l (HsFieldBind _ fs arg pun))       = do { (arg, fv) <- rnLExpr arg-           ; return $ (L l (HsRecField { hsRecFieldAnn = noAnn-                                       , hsRecFieldLbl = fmap rnFieldLabelStrings fs-                                       , hsRecFieldArg = arg-                                       , hsRecPun = pun}), fv) }+           ; return $+               (L l (HsFieldBind {+                         hfbAnn = noAnn+                       , hfbLHS = fmap rnFieldLabelStrings fs+                       , hfbRHS = arg+                       , hfbPun = pun}), fv ) }
compiler/GHC/Rename/Fixity.hs view
@@ -30,15 +30,11 @@ import GHC.Types.SrcLoc  import GHC.Utils.Outputable-import GHC.Utils.Panic  import GHC.Data.Maybe  import GHC.Rename.Unbound -import Data.List (groupBy)-import Data.Function    ( on )- {- ********************************************************* *                                                      *@@ -184,39 +180,10 @@ lookupTyFixityRn :: LocatedN Name -> RnM Fixity lookupTyFixityRn = lookupFixityRn . unLoc --- | Look up the fixity of a (possibly ambiguous) occurrence of a record field--- selector.  We use 'lookupFixityRn'' so that we can specify the 'OccName' as--- the field label, which might be different to the 'OccName' of the selector--- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are--- multiple possible selectors with different fixities, generate an error.-lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity-lookupFieldFixityRn (Unambiguous n lrdr)+-- | Look up the fixity of an occurrence of a record field selector.+-- We use 'lookupFixityRn'' so that we can specify the 'OccName' as+-- the field label, which might be different to the 'OccName' of the+-- selector 'Name' if @DuplicateRecordFields@ is in use (#1173).+lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity+lookupFieldFixityRn (FieldOcc n lrdr)   = lookupFixityRn' n (rdrNameOcc (unLoc lrdr))-lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr)-  where-    get_ambiguous_fixity :: RdrName -> RnM Fixity-    get_ambiguous_fixity rdr_name = do-      traceRn "get_ambiguous_fixity" (ppr rdr_name)-      rdr_env <- getGlobalRdrEnv-      let elts =  lookupGRE_RdrName rdr_name rdr_env--      fixities <- groupBy ((==) `on` snd) . zip elts-                  <$> mapM lookup_gre_fixity elts--      case fixities of-        -- There should always be at least one fixity.-        -- Something's very wrong if there are no fixity candidates, so panic-        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"-        [ (_, fix):_ ] -> return fix-        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)-                  >> return (Fixity NoSourceText minPrecedence InfixL)--    lookup_gre_fixity gre = lookupFixityRn' (greMangledName gre) (greOccName gre)--    ambiguous_fixity_err rn ambigs-      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)-             , hang (text "Conflicts: ") 2 . vcat .-               map format_ambig $ concat ambigs ]--    format_ambig (elt, fix) = hang (ppr fix)-                                 2 (pprNameProvenance elt)
compiler/GHC/Rename/HsType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE LambdaCase          #-}@@ -12,7 +12,7 @@  module GHC.Rename.HsType (         -- Type related stuff-        rnHsType, rnLHsType, rnLHsTypes, rnContext,+        rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,         rnHsKind, rnLHsKind, rnLHsTypeArgs,         rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars,         HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType,@@ -53,7 +53,7 @@                          , checkShadowedRdrNames ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn                          , lookupTyFixityRn )-import GHC.Rename.Unbound ( notInScopeErr )+import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names@@ -68,6 +68,7 @@ import GHC.Types.Basic  ( TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt @@ -76,8 +77,6 @@ import Data.List.NonEmpty (NonEmpty(..)) import Control.Monad -#include "GhclibHsVersions.h"- {- These type renamers are in a separate module, rather than in (say) GHC.Rename.Module, to break several loops.@@ -255,34 +254,27 @@                                 , hst_tele = tele', hst_body = hs_body' }                     , fvs) } -    rn_ty env (HsQualTy { hst_ctxt = m_ctxt+    rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt                         , hst_body = hs_ty })-      | Just (L cx hs_ctxt) <- m_ctxt-      , Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt+      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt       , L lx (HsWildCardTy _)  <- ignoreParens hs_ctxt_last       = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1            ; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1            ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)]            ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty            ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = Just (L cx hs_ctxt')+                              , hst_ctxt = L cx hs_ctxt'                               , hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) } -      | Just (L cx hs_ctxt) <- m_ctxt+      | otherwise       = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt            ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty            ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = Just (L cx hs_ctxt')+                              , hst_ctxt = L cx hs_ctxt'                               , hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) } -      | Nothing <- m_ctxt-      = do { (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty-           ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = Nothing-                              , hst_body = hs_ty' }-                    , fvs2) }      rn_ty env hs_ty = rnHsTyKi env hs_ty @@ -575,19 +567,27 @@ rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args  ---------------rnTyKiContext :: RnTyKiEnv -> Maybe (LHsContext GhcPs)-              -> RnM (Maybe (LHsContext GhcRn), FreeVars)-rnTyKiContext _ Nothing = return (Nothing, emptyFVs)-rnTyKiContext env (Just (L loc cxt))+rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs+              -> RnM (LHsContext GhcRn, FreeVars)+rnTyKiContext env (L loc cxt)   = do { traceRn "rncontext" (ppr cxt)        ; let env' = env { rtke_what = RnConstraint }        ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt-       ; return (Just $ L loc cxt', fvs) }+       ; return (L loc cxt', fvs) } -rnContext :: HsDocContext -> Maybe (LHsContext GhcPs)-          -> RnM (Maybe (LHsContext GhcRn), FreeVars)+rnContext :: HsDocContext -> LHsContext GhcPs+          -> RnM (LHsContext GhcRn, FreeVars) rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta +rnMaybeContext :: HsDocContext -> Maybe (LHsContext GhcPs)+          -> RnM (Maybe (LHsContext GhcRn), FreeVars)+rnMaybeContext _ Nothing = return (Nothing, emptyFVs)+rnMaybeContext doc (Just theta)+  = do { (theta', fvs) <- rnContext doc theta+       ; return (Just theta', fvs)+       }++ -------------- rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnLHsTyKi env (L loc ty)@@ -745,7 +745,7 @@       mb_name <- lookupLocalOccRn_maybe rdr_name       when (isNothing mb_name) $         addErr $ withHsDocContext (rtke_ctxt env) $-        notInScopeErr rdr_name+        notInScopeErr WL_LocalOnly rdr_name  rnHsTyKi env ty@(HsExplicitListTy _ ip tys)   = do { data_kinds <- xoptM LangExt.DataKinds@@ -1386,19 +1386,17 @@ --------------------------- --      Default case mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment-  = ASSERT2( right_op_ok fix (unLoc e2),-             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2-    )+  = assertPpr (right_op_ok fix (unLoc e2))+              (ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $     return (OpApp fix e1 op e2)  ----------------------------  -- | Name of an operator in an operator application or section-data OpName = NormalOp Name         -- ^ A normal identifier-            | NegateOp              -- ^ Prefix negation-            | UnboundOp OccName     -- ^ An unbound indentifier-            | RecFldOp (AmbiguousFieldOcc GhcRn)-              -- ^ A (possibly ambiguous) record field occurrence+data OpName = NormalOp Name             -- ^ A normal identifier+            | NegateOp                  -- ^ Prefix negation+            | UnboundOp OccName         -- ^ An unbound indentifier+            | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence  instance Outputable OpName where   ppr (NormalOp n)   = ppr n@@ -1411,7 +1409,7 @@ -- See GHC.Rename.Expr.rnUnboundVar get_op (L _ (HsVar _ n))         = NormalOp (unLoc n) get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv-get_op (L _ (HsRecFld _ fld))    = RecFldOp fld+get_op (L _ (HsRecSel _ fld))    = RecFldOp fld get_op other                     = pprPanic "get_op" (ppr other)  -- Parser left-associates everything, but@@ -1429,7 +1427,7 @@ -- And "deriving" code should respect this (use HsPar if not) mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn) mkNegAppRn neg_arg neg_name-  = ASSERT( not_op_app (unLoc neg_arg) )+  = assert (not_op_app (unLoc neg_arg)) $     return (NegApp noExtField neg_arg neg_name)  not_op_app :: HsExpr id -> Bool@@ -1500,7 +1498,7 @@         }  mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment-  = ASSERT( not_op_pat (unLoc p2) )+  = assert (not_op_pat (unLoc p2)) $     return $ ConPat       { pat_con_ext = noExtField       , pat_con = op@@ -1575,8 +1573,7 @@                                  (arg_op, arg_fix) section)  -- | Look up the fixity for an operator name.  Be careful to use--- 'lookupFieldFixityRn' for (possibly ambiguous) record fields--- (see #13132).+-- 'lookupFieldFixityRn' for record fields (see #13132). lookupFixityOp :: OpName -> RnM Fixity lookupFixityOp (NormalOp n)  = lookupFixityRn n lookupFixityOp NegateOp      = lookupFixityRn negateName@@ -1908,9 +1905,8 @@ extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })   = maybe [] extractHsTyRdrTyVars ksig -extract_lctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> FreeKiTyVars-extract_lctxt Nothing     = id-extract_lctxt (Just ctxt) = extract_ltys (unLoc ctxt)+extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars+extract_lctxt ctxt = extract_ltys (unLoc ctxt)  extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]                     -> FreeKiTyVars -> FreeKiTyVars
compiler/GHC/Rename/Module.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}@@ -16,8 +16,6 @@         rnSrcDecls, addTcgDUs, findSplice     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )@@ -35,7 +33,7 @@                         , newLocalBndrsRn                         , withHsDocContext, noNestedForallsContextsErr                         , addNoNestedForallsContextsErr, checkInferredVars )-import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr )+import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad@@ -58,7 +56,7 @@ import GHC.Data.FastString import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session-import GHC.Utils.Misc   ( debugIsOn, lengthExceeds, partitionWith )+import GHC.Utils.Misc   ( lengthExceeds, partitionWith ) import GHC.Utils.Panic import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )@@ -140,8 +138,13 @@    -- (D2) Rename the left-hand sides of the value bindings.    --     This depends on everything from (B) being in scope.    --     It uses the fixity env from (A) to bind fixities for view patterns.-   new_lhs <- rnTopBindsLHS local_fix_env val_decls ; +   -- We need to throw an error on such value bindings when in a boot file.+   is_boot <- tcIsHsBootOrSig ;+   new_lhs <- if is_boot+    then rnTopBindsLHSBoot local_fix_env val_decls+    else rnTopBindsLHS     local_fix_env val_decls ;+    -- Bind the LHSes (and their fixities) in the global rdr environment    let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ;                     -- Excludes pattern-synonym binders@@ -168,7 +171,6 @@    -- (F) Rename Value declarations right-hand sides    traceRn "Start rnmono" empty ;    let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;-   is_boot <- tcIsHsBootOrSig ;    (rn_val_decls, bind_dus) <- if is_boot     -- For an hs-boot, use tc_bndrs (which collects how we're renamed     -- signatures), since val_bndr_set is empty (there are no x = ...@@ -320,8 +322,10 @@                 -> RnM (AnnProvenance GhcRn, FreeVars) rnAnnProvenance provenance = do     provenance' <- case provenance of-      ValueAnnProvenance n -> ValueAnnProvenance <$> lookupLocatedTopBndrRnN n-      TypeAnnProvenance n  -> TypeAnnProvenance  <$> lookupLocatedTopBndrRnN n+      ValueAnnProvenance n -> ValueAnnProvenance+                          <$> lookupLocatedTopBndrRnN n+      TypeAnnProvenance n  -> TypeAnnProvenance+                          <$> lookupLocatedTopConstructorRnN n       ModuleAnnProvenance  -> return ModuleAnnProvenance     return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) @@ -761,10 +765,10 @@          -- See Note [Renaming associated types].          -- Per that Note, the LHS type variables consist of:          ---         -- * The variables mentioned in the instance's type patterns+         -- - The variables mentioned in the instance's type patterns          --   (pat_fvs), and          ---         -- * The variables mentioned in an outermost kind signature on the+         -- - The variables mentioned in an outermost kind signature on the          --   RHS. This is a subset of `rhs_fvs`. To compute it, we look up          --   each RdrName in `extra_kvars` to find its corresponding Name in          --   the LocalRdrEnv.@@ -1343,7 +1347,7 @@     text "LHS must be of form (f e1 .. en) where f is not forall'd"   where     err = case bad_e of-            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv)+            HsUnboundVar _ uv -> notInScopeErr WL_Global (mkRdrUnqual uv)             _                 -> text "Illegal expression:" <+> ppr bad_e  {- **************************************************************@@ -1523,8 +1527,11 @@               all_groups = first_group ++ groups -       ; MASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map-                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )+       ; massertPpr (null final_inst_ds)+                    (ppr instds_w_fvs+                     $$ ppr inst_ds_map+                     $$ ppr (flattenSCCs tycl_sccs)+                     $$ ppr final_inst_ds)         ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)        ; return (all_groups, all_fvs) }@@ -1776,7 +1783,7 @@  rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,                       tcdFixity = fixity, tcdRhs = rhs })-  = do { tycon' <- lookupLocatedTopBndrRnN tycon+  = do { tycon' <- lookupLocatedTopConstructorRnN tycon        ; let kvs = extractHsTyRdrTyVarsKindVars rhs              doc = TySynCtx tycon        ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)@@ -1792,7 +1799,7 @@       tcdFixity = fixity,       tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data                                    , dd_kindSig = kind_sig} })-  = do { tycon' <- lookupLocatedTopBndrRnN tycon+  = do { tycon' <- lookupLocatedTopConstructorRnN tycon        ; let kvs = extractDataDefnKindVars defn              doc = TyDataCtx tycon        ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)@@ -1813,7 +1820,7 @@                         tcdFDs = fds, tcdSigs = sigs,                         tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,                         tcdDocs = docs})-  = do  { lcls' <- lookupLocatedTopBndrRnN lcls+  = do  { lcls' <- lookupLocatedTopConstructorRnN lcls         ; let cls' = unLoc lcls'               kvs = []  -- No scoped kind vars except those in                         -- kind signatures on the tyvars@@ -1822,7 +1829,7 @@         ; ((tyvars', context', fds', ats'), stuff_fvs)             <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do                   -- Checks for distinct tyvars-             { (context', cxt_fvs) <- rnContext cls_doc context+             { (context', cxt_fvs) <- rnMaybeContext cls_doc context              ; fds'  <- rnFds fds                          -- The fundeps have no free variables              ; (ats', fv_ats) <- rnATDecls cls' ats@@ -1919,7 +1926,7 @@         ; (m_sig', sig_fvs) <- case m_sig of              Just sig -> first Just <$> rnLHsKind doc sig              Nothing  -> return (Nothing, emptyFVs)-        ; (context', fvs1) <- rnContext doc context+        ; (context', fvs1) <- rnMaybeContext doc context         ; (derivs',  fvs3) <- rn_derivs derivs          -- For the constructor declarations, drop the LocalRdrEnv@@ -1934,7 +1941,7 @@          ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`                         con_fvs `plusFV` sig_fvs-        ; return ( HsDataDefn { dd_ext = noAnn+        ; return ( HsDataDefn { dd_ext = noExtField                               , dd_ND = new_or_data, dd_cType = cType                               , dd_ctxt = context', dd_kindSig = m_sig'                               , dd_cons = condecls'@@ -2098,7 +2105,7 @@                              , fdFixity = fixity                              , fdInfo = info, fdResultSig = res_sig                              , fdInjectivityAnn = injectivity })-  = do { tycon' <- lookupLocatedTopBndrRnN tycon+  = do { tycon' <- lookupLocatedTopConstructorRnN tycon        ; ((tyvars', res_sig', injectivity'), fv1) <-             bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->             do { let rn_sig = rnFamResultSig doc@@ -2281,7 +2288,7 @@                            , con_mb_cxt = mcxt, con_args = args                            , con_doc = mb_doc, con_forall = forall })   = do  { _        <- addLocMA checkConName name-        ; new_name <- lookupLocatedTopBndrRnN name+        ; new_name <- lookupLocatedTopConstructorRnN name          -- We bind no implicit binders here; this is just like         -- a nested HsForAllTy.  E.g. consider@@ -2316,7 +2323,7 @@                        , con_res_ty  = res_ty                        , con_doc     = mb_doc })   = do  { mapM_ (addLocMA checkConName) names-        ; new_names <- mapM lookupLocatedTopBndrRnN names+        ; new_names <- mapM (lookupLocatedTopConstructorRnN) names          ; let -- We must ensure that we extract the free tkvs in left-to-right               -- order of their appearance in the constructor type.@@ -2355,7 +2362,7 @@ rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)             -> RnM (Maybe (LHsContext GhcRn), FreeVars) rnMbContext _    Nothing    = return (Nothing, emptyFVs)-rnMbContext doc cxt = do { (ctx',fvs) <- rnContext doc cxt+rnMbContext doc cxt = do { (ctx',fvs) <- rnMaybeContext doc cxt                          ; return (ctx',fvs) }  rnConDeclH98Details ::@@ -2428,7 +2435,7 @@                                        , psb_args = RecCon as }))) <- bind       = do           bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)-          let field_occs = map ((\ f -> L (getLocA (rdrNameFieldOcc f)) f) . recordPatSynField) as+          let field_occs = map ((\ f -> L (getLocA (foLabel f)) f) . recordPatSynField) as           flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs           return ((bnd_name, flds): names)       | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind
compiler/GHC/Rename/Names.hs view
@@ -4,7 +4,7 @@ Extracting imported and top-level names in scope -} -{-# LANGUAGE CPP, NondecreasingIndentation #-}+{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -22,16 +22,12 @@         checkConName,         mkChildEnv,         findChildren,-        dodgyMsg,-        dodgyMsgInsert,         findImportUsage,         getMinimalImports,         printMinimalImports,         ImportDeclUsage     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -42,6 +38,7 @@ import GHC.Rename.Fixity import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad @@ -73,6 +70,7 @@ import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.HpcInfo+import GHC.Types.Unique.FM  import GHC.Unit import GHC.Unit.Module.Warnings@@ -200,9 +198,20 @@     stuff2 <- mapAndReportM (rnImportDecl this_mod) source     -- Safe Haskell: See Note [Tracking Trust Transitively]     let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)-    return (decls, rdr_env, imp_avails, hpc_usage)+    -- Update imp_boot_mods if imp_direct_mods mentions any of them+    let final_import_avail = clobberSourceImports imp_avails+    return (decls, rdr_env, final_import_avail, hpc_usage)    where+    clobberSourceImports imp_avails =+      imp_avails { imp_boot_mods = imp_boot_mods' }+      where+        imp_boot_mods' = mergeUFM combJ id (const mempty)+                            (imp_boot_mods imp_avails)+                            (imp_direct_dep_mods imp_avails)++        combJ (GWIB _ IsBoot) x = Just x+        combJ r _               = Just r     -- See Note [Combining ImportAvails]     combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]             -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)@@ -341,7 +350,7 @@      -- Compiler sanity check: if the import didn't say     -- {-# SOURCE #-} we should not get a hi-boot file-    WARN( (want_boot == NotBoot) && (mi_boot iface == IsBoot), ppr imp_mod_name ) do+    warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) (ppr imp_mod_name) $ do      -- Issue a user warning for a redundant {- SOURCE -} import     -- NB that we arrange to read all the ordinary imports before@@ -424,6 +433,7 @@       deps       = mi_deps iface       trust      = getSafeMode $ mi_trust iface       trust_pkg  = mi_trust_pkg iface+      is_sig     = mi_hsc_src iface == HsigFile        -- If the module exports anything defined in this module, just       -- ignore it.  Reason: otherwise it looks as if there are two@@ -451,61 +461,69 @@       -- 'imp_finsts' if it defines an orphan or instance family; thus the       -- orph_iface/has_iface tests. -      orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )+      orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` dep_orphs deps)) (ppr imp_sem_mod <+> ppr (dep_orphs deps)) $                              imp_sem_mod : dep_orphs deps               | otherwise  = dep_orphs deps -      finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )+      finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` dep_finsts deps)) (ppr imp_sem_mod <+> ppr (dep_orphs deps)) $                             imp_sem_mod : dep_finsts deps              | otherwise  = dep_finsts deps +      -- Trusted packages are a lot like orphans.+      trusted_pkgs | mod_safe' = S.fromList (dep_trusted_pkgs deps)+                   | otherwise = S.empty++       pkg = moduleUnit (mi_module iface)       ipkg = toUnitId pkg        -- Does this import mean we now require our own pkg       -- to be trusted? See Note [Trust Own Package]       ptrust = trust == Sf_Trustworthy || trust_pkg+      pkg_trust_req+        | isHomeUnit home_unit pkg = ptrust+        | otherwise = False -      (dependent_mods, dependent_pkgs, pkg_trust_req)-         | isHomeUnit home_unit pkg =-            -- Imported module is from the home package-            -- Take its dependent modules and add imp_mod itself-            -- Take its dependent packages unchanged-            ---            -- NB: (dep_mods deps) might include a hi-boot file-            -- for the module being compiled, CM. Do *not* filter-            -- this out (as we used to), because when we've-            -- finished dealing with the direct imports we want to-            -- know if any of them depended on CM.hi-boot, in-            -- which case we should do the hi-boot consistency-            -- check.  See GHC.Iface.Load.loadHiBootInterface-            ( GWIB { gwib_mod = moduleName imp_mod, gwib_isBoot = want_boot } : dep_mods deps-            , dep_pkgs deps-            , ptrust-            )+      dependent_pkgs = if isHomeUnit home_unit pkg+                        then S.empty+                        else S.fromList [ipkg] -         | otherwise =-            -- Imported module is from another package-            -- Dump the dependent modules-            -- Add the package imp_mod comes from to the dependent packages-            ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))-                   , ppr ipkg <+> ppr (dep_pkgs deps) )-            ([], (ipkg, False) : dep_pkgs deps, False)+      direct_mods = mkModDeps $ if isHomeUnit home_unit pkg+                      then [GWIB (moduleName imp_mod) want_boot]+                      else [] +      dep_boot_mods_map = mkModDeps (dep_boot_mods deps)++      boot_mods+        -- If we are looking for a boot module, it must be HPT+        | IsBoot <- want_boot = addToUFM dep_boot_mods_map (moduleName imp_mod) (GWIB (moduleName imp_mod) IsBoot)+        -- Now we are importing A properly, so don't go looking for+        -- A.hs-boot+        | isHomeUnit home_unit pkg = dep_boot_mods_map+        -- There's no boot files to find in external imports+        | otherwise = emptyUFM++      sig_mods =+        if is_sig+          then moduleName imp_mod : dep_sig_mods deps+          else dep_sig_mods deps++   in ImportAvails {           imp_mods       = unitModuleEnv (mi_module iface) [imported_by],           imp_orphs      = orphans,           imp_finsts     = finsts,-          imp_dep_mods   = mkModDeps dependent_mods,-          imp_dep_pkgs   = S.fromList . map fst $ dependent_pkgs,+          imp_sig_mods   = sig_mods,+          imp_direct_dep_mods = direct_mods,+          imp_dep_direct_pkgs = dependent_pkgs,+          imp_boot_mods = boot_mods,+           -- Add in the imported modules trusted package           -- requirements. ONLY do this though if we import the           -- module as a safe import.           -- See Note [Tracking Trust Transitively]           -- and Note [Trust Transitive Property]-          imp_trust_pkgs = if mod_safe'-                               then S.fromList . map fst $ filter snd dependent_pkgs-                               else S.empty,+          imp_trust_pkgs = trusted_pkgs,           -- Do we require our own pkg to be trusted?           -- See Note [Trust Own Package]           imp_trust_own_pkg = pkg_trust_req@@ -1127,16 +1145,16 @@             -> (GreName, AvailInfo, Maybe Name)     combine (NormalGreName name1, a1@(AvailTC p1 _), mb1)             (NormalGreName name2, a2@(AvailTC p2 _), mb2)-      = ASSERT2( name1 == name2 && isNothing mb1 && isNothing mb2-               , ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2 )+      = assertPpr (name1 == name2 && isNothing mb1 && isNothing mb2)+                  (ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2) $         if p1 == name1 then (NormalGreName name1, a1, Just p2)                        else (NormalGreName name1, a2, Just p1)     -- 'combine' may also be called for pattern synonyms which appear both     -- unassociated and associated (see Note [Importing PatternSynonyms]).     combine (c1, a1, mb1) (c2, a2, mb2)-      = ASSERT2( c1 == c2 && isNothing mb1 && isNothing mb2-                          && (isAvailTC a1 || isAvailTC a2)-               , ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2 )+      = assertPpr (c1 == c2 && isNothing mb1 && isNothing mb2+                          && (isAvailTC a1 || isAvailTC a2))+                  (ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2) $         if isAvailTC a1 then (c1, a1, Nothing)                         else (c1, a2, Nothing) @@ -1164,9 +1182,9 @@         where             -- Warn when importing T(..) if T was exported abstractly             emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $-              addDiagnostic (WarningWithFlag Opt_WarnDodgyImports) (dodgyImportWarn n)+              addTcRnDiagnostic (TcRnDodgyImports n)             emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $-              addDiagnostic (WarningWithFlag Opt_WarnMissingImportList) (missingImportListItem ieRdr)+              addTcRnDiagnostic (TcRnMissingImportList ieRdr)             emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $               addDiagnostic (WarningWithFlag Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie)) @@ -1464,6 +1482,28 @@ *                                                                      * ********************************************************************* -} +{-+Note [Missing signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~+There are four warning flags in play:++  * -Wmissing-exported-signatures+    Warn about any exported top-level function/value without a type signature.+    Does not include pattern synonyms.++  * -Wmissing-signatures+    Warn about any top-level function/value without a type signature. Does not+    include pattern synonyms. Takes priority over -Wmissing-exported-signatures.++  * -Wmissing-exported-pattern-synonym-signatures+    Warn about any exported pattern synonym without a type signature.++  * -Wmissing-pattern-synonym-signatures+    Warn about any pattern synonym without a type signature. Takes priority over+    -Wmissing-exported-pattern-synonym-signatures.++-}+ -- | Warn the user about top level binders that lack type signatures. -- Called /after/ type inference, so that we can report the -- inferred type of the function@@ -1477,46 +1517,56 @@           -- Warn about missing signatures          -- Do this only when we have a type to offer-       ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures-       ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures-       ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures+       ; warn_binds             <- woptM Opt_WarnMissingSignatures+       ; warn_exported_binds    <- woptM Opt_WarnMissingExportedSignatures+       ; warn_pat_syns          <- woptM Opt_WarnMissingPatternSynonymSignatures+       ; warn_exported_pat_syns <- woptM Opt_WarnMissingExportedPatternSynonymSignatures +         -- See Note [Missing signatures]        ; let add_sig_warns-               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures-               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures-               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures-               | otherwise          = return ()+               = when (warn_pat_syns || warn_exported_pat_syns)+                      (mapM_ add_pat_syn_warn pat_syns) >>+                 when (warn_binds || warn_exported_binds)+                      (mapM_ add_bind_warn binds) -             add_warns flag-                = when (warn_missing_sigs || warn_only_exported)-                       (mapM_ add_bind_warn binds) >>-                  when (warn_missing_sigs || warn_pat_syns)-                       (mapM_ add_pat_syn_warn pat_syns)-                where-                  add_pat_syn_warn p-                    = add_warn name $-                      hang (text "Pattern synonym with no type signature:")-                         2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)-                    where-                      name  = patSynName p-                      pp_ty = pprPatSynType p+             add_pat_syn_warn p+               = when export_check $+                 add_warn name flag $+                 hang (text "Pattern synonym with no type signature:")+                    2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)+               where+                 name  = patSynName p+                 pp_ty = pprPatSynType p+                 export_check = warn_pat_syns || name `elemNameSet` exports+                 flag | warn_pat_syns+                      = Opt_WarnMissingPatternSynonymSignatures+                      | otherwise+                      = Opt_WarnMissingExportedPatternSynonymSignatures -                  add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()-                  add_bind_warn id-                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?-                         ; let name    = idName id-                               (_, ty) = tidyOpenType env (idType id)-                               ty_msg  = pprSigmaType ty-                         ; add_warn name $-                           hang (text "Top-level binding with no type signature:")-                              2 (pprPrefixName name <+> dcolon <+> ty_msg) }+             add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()+             add_bind_warn id+               = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?+                    ; let (_, ty) = tidyOpenType env (idType id)+                          ty_msg  = pprSigmaType ty -                  add_warn name msg-                    = when (name `elemNameSet` sig_ns && export_check name)-                           (addDiagnosticAt (WarningWithFlag flag) (getSrcSpan name) msg)+                    ; when export_check $+                      add_warn name flag $+                      hang (text "Top-level binding with no type signature:")+                         2 (pprPrefixName name <+> dcolon <+> ty_msg) }+               where+                 name = idName id+                 export_check = warn_binds || name `elemNameSet` exports+                 flag | warn_binds+                      = Opt_WarnMissingSignatures+                      | otherwise+                      = Opt_WarnMissingExportedSignatures -                  export_check name-                    = warn_missing_sigs || not warn_only_exported || name `elemNameSet` exports+             add_warn name flag msg+               = when not_ghc_generated+                      (addDiagnosticAt (WarningWithFlag flag) (getSrcSpan name) msg)+               where+                 not_ghc_generated+                   = name `elemNameSet` sig_ns         ; add_sig_warns } @@ -2005,26 +2055,6 @@ illegalImportItemErr :: SDoc illegalImportItemErr = text "Illegal import item" -dodgyImportWarn :: RdrName -> SDoc-dodgyImportWarn item-  = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs)--dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc-dodgyMsg kind tc ie-  = sep [ text "The" <+> kind <+> text "item"-                    -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))-                     <+> quotes (ppr ie)-                <+> text "suggests that",-          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",-          text "but it has none" ]--dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)-dodgyMsgInsert tc = IEThingAll noAnn ii-  where-    ii :: LIEWrappedName (IdP (GhcPass p))-    ii = noLocA (IEName $ noLocA tc)-- addDupDeclErr :: [GlobalRdrElt] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" addDupDeclErr gres@(gre : _)@@ -2047,10 +2077,6 @@ missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod   = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list"--missingImportListItem :: IE GhcPs -> SDoc-missingImportListItem ie-  = text "The import item" <+> quotes (ppr ie) <+> text "does not have an explicit import list"  moduleWarn :: ModuleName -> WarningTxt -> SDoc moduleWarn mod (WarningTxt _ txt)
compiler/GHC/Rename/Pat.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-}@@ -49,8 +48,6 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) -#include "GhclibHsVersions.h"- import GHC.Hs import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Zonk   ( hsOverLitName )@@ -71,7 +68,7 @@ import GHC.Utils.Misc import GHC.Data.List.SetOps( removeDups ) import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Literal   ( inCharRange ) import GHC.Builtin.Types   ( nilDataCon )@@ -149,7 +146,7 @@  lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name) lookupConCps con_rdr-  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr+  = CpsRn (\k -> do { con_name <- lookupLocatedOccRnConstr con_rdr                     ; (r, fvs) <- k con_name                     ; return (r, addOneFV fvs (unLoc con_name)) })     -- We add the constructor name to the free vars@@ -403,8 +400,9 @@  rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) rnPatAndThen _  (WildPat _)   = return (WildPat noExtField)-rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat-                                     ; return (ParPat x pat') }+rnPatAndThen mk (ParPat x lpar pat rpar) =+  do { pat' <- rnLPatAndThen mk pat+     ; return (ParPat x lpar pat' rpar) } rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat                                      ; return (LazyPat noExtField pat') } rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat@@ -593,15 +591,15 @@   where     mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)     rn_field (L l fld, n') =-      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)-         ; return (L l (fld { hsRecFieldArg = arg' })) }+      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hfbRHS fld)+         ; return (L l (fld { hfbRHS = arg' })) }      loc = maybe noSrcSpan getLoc dd      -- Get the arguments of the implicit binders     implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats       where-        implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)+        implicit_pats = map (hfbRHS . unLoc) (drop n fs)      -- Don't warn for let P{..} = ... in ...     check_unused_wildcard = case mk of@@ -662,11 +660,11 @@     rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg)            -> RnM (LHsRecField GhcRn (LocatedA arg))     rn_fld pun_ok parent (L l-                           (HsRecField-                              { hsRecFieldLbl =+                           (HsFieldBind+                              { hfbLHS =                                   (L loc (FieldOcc _ (L ll lbl)))-                              , hsRecFieldArg = arg-                              , hsRecPun      = pun }))+                              , hfbRHS = arg+                              , hfbPun      = pun }))       = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl            ; arg' <- if pun                      then do { checkErr pun_ok (badPun (L loc lbl))@@ -674,11 +672,11 @@                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)                              ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) }                      else return arg-           ; return (L l (HsRecField-                             { hsRecFieldAnn = noAnn-                             , hsRecFieldLbl = (L loc (FieldOcc sel (L ll lbl)))-                             , hsRecFieldArg = arg'-                             , hsRecPun      = pun })) }+           ; return (L l (HsFieldBind+                             { hfbAnn = noAnn+                             , hfbLHS = (L loc (FieldOcc sel (L ll lbl)))+                             , hfbRHS = arg'+                             , hfbPun      = pun })) }       rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in GHC.Hs.Pat@@ -691,7 +689,7 @@                                 -- isn't in scope the constructor lookup will add                                 -- an error but still return an unbound name. We                                 -- don't want that to screw up the dot-dot fill-in stuff.-      = ASSERT( flds `lengthIs` n )+      = assert (flds `lengthIs` n) $         do { dd_flag <- xoptM LangExt.RecordWildCards            ; checkErr dd_flag (needFlagDotDot ctxt)            ; (rdr_env, lcl_env) <- getRdrEnvs@@ -719,12 +717,12 @@             ; addUsedGREs dot_dot_gres            ; let locn = noAnnSrcSpan loc-           ; return [ L (noAnnSrcSpan loc) (HsRecField-                        { hsRecFieldAnn = noAnn-                        , hsRecFieldLbl+           ; return [ L (noAnnSrcSpan loc) (HsFieldBind+                        { hfbAnn = noAnn+                        , hfbLHS                            = L loc (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))-                        , hsRecFieldArg = L locn (mk_arg loc arg_rdr)-                        , hsRecPun      = False })+                        , hfbRHS = L locn (mk_arg loc arg_rdr)+                        , hfbPun      = False })                     | fl <- dot_dot_fields                     , let sel     = flSelector fl                     , let arg_rdr = mkVarUnqual (flLabel fl) ] }@@ -766,9 +764,9 @@   where     rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs            -> RnM (LHsRecUpdField GhcRn, FreeVars)-    rn_fld pun_ok dup_fields_ok (L l (HsRecField { hsRecFieldLbl = L loc f-                                               , hsRecFieldArg = arg-                                               , hsRecPun      = pun }))+    rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f+                                                  , hfbRHS = arg+                                                  , hfbPun      = pun }))       = do { let lbl = rdrNameAmbiguousFieldOcc f            ; mb_sel <- setSrcSpan loc $                       -- Defer renaming of overloaded fields to the typechecker@@ -788,10 +786,10 @@                                            in (Unambiguous sel_name (L (noAnnSrcSpan loc) lbl), fvs `addOneFV` sel_name)                    AmbiguousFields       -> (Ambiguous   noExtField (L (noAnnSrcSpan loc) lbl), fvs) -           ; return (L l (HsRecField { hsRecFieldAnn = noAnn-                                     , hsRecFieldLbl = L loc lbl'-                                     , hsRecFieldArg = arg''-                                     , hsRecPun      = pun }), fvs') }+           ; return (L l (HsFieldBind { hfbAnn = noAnn+                                      , hfbLHS = L loc lbl'+                                      , hfbRHS = arg''+                                      , hfbPun = pun }), fvs') }      dup_flds :: [NE.NonEmpty RdrName]         -- Each list represents a RdrName that occurred more than once@@ -802,14 +800,14 @@   getFieldIds :: [LHsRecField GhcRn arg] -> [Name]-getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds+getFieldIds flds = map (hsRecFieldSel . unLoc) flds  getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName] getFieldLbls flds-  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unXRec @p) flds+  = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds  getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]-getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds  needFlagDotDot :: HsRecFieldContext -> SDoc needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
compiler/GHC/Rename/Splice.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -11,14 +11,13 @@         , traceSplice, SpliceInfo(..)   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Name import GHC.Types.Name.Set import GHC.Hs import GHC.Types.Name.Reader+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Driver.Env.Types @@ -451,11 +450,11 @@                 runRnSplice UntypedExpSplice runMetaE ppr rn_splice            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( HsPar noAnn $ HsSpliceE noAnn-                            . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                            . HsSplicedExpr <$>-                            lexpr3-                    , fvs)+           ; let e =  HsSpliceE noAnn+                    . HsSpliced noExtField (ThModFinalizers mod_finalizers)+                    . HsSplicedExpr+                        <$> lexpr3+           ; return (gHsPar e, fvs)            }  {- Note [Running splices in the Renamer]@@ -695,12 +694,11 @@            ; (pat, mod_finalizers) <-                 runRnSplice UntypedPatSplice runMetaP ppr rn_splice              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( Left $ ParPat noAnn $ ((SplicePat noExtField)-                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                              . HsSplicedPat)  `mapLoc`-                              pat-                    , emptyFVs-                    ) }+           ; let p =  SplicePat noExtField+                    . HsSpliced noExtField (ThModFinalizers mod_finalizers)+                    . HsSplicedPat+                        <$> pat+           ; return (Left $ gParPat p, emptyFVs) }               -- Wrap the result of the quasi-quoter in parens so that we don't               -- lose the outermost location set by runQuasiQuote (#7918) @@ -912,9 +910,7 @@               pend_splice = PendingRnSplice UntypedExpSplice name lift_expr            -- Warning for implicit lift (#17804)-        ; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)-                          (text "The variable" <+> quotes (ppr name) <+>-                           text "is implicitly lifted in the TH quotation")+        ; addDetailedDiagnostic (TcRnImplicitLift name)            -- Update the pending splices         ; ps <- readMutVar ps_var
compiler/GHC/Rename/Unbound.hs view
@@ -9,11 +9,15 @@    , mkUnboundNameRdr    , isUnboundName    , reportUnboundName+   , reportUnboundName'    , unknownNameSuggestions+   , WhatLooking(..)    , WhereLooking(..)+   , LookingFor(..)    , unboundName    , unboundNameX    , notInScopeErr+   , nameSpacesRelated    , exactNameErr    ) where@@ -31,6 +35,8 @@ import GHC.Data.Maybe import GHC.Data.FastString +import qualified GHC.LanguageExtensions as LangExt+ import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader@@ -51,28 +57,49 @@ ************************************************************************ -} -data WhereLooking = WL_Any        -- Any binding+-- What kind of suggestion are we looking for? #19843+data WhatLooking = WL_Anything    -- Any binding+                 | WL_Constructor -- Constructors and pattern synonyms+                        -- E.g. in K { f1 = True }, if K is not in scope,+                        -- suggest only constructors+                 | WL_RecField    -- Record fields+                        -- E.g. in K { f1 = True, f2 = False }, if f2 is not in+                        -- scope, suggest only constructor fields+                 | WL_None        -- No suggestions+                        -- WS_None is used for rebindable syntax, where there+                        -- is no point in suggesting alternative spellings+                 deriving Eq++data WhereLooking = WL_Anywhere   -- Any binding                   | WL_Global     -- Any top-level binding (local or imported)                   | WL_LocalTop   -- Any top-level binding in this module                   | WL_LocalOnly                         -- Only local bindings-                        -- (pattern synonyms declaractions,-                        -- see Note [Renaming pattern synonym variables])+                        -- (pattern synonyms declarations,+                        -- see Note [Renaming pattern synonym variables]+                        -- in GHC.Rename.Bind) +data LookingFor = LF { lf_which :: WhatLooking+                     , lf_where :: WhereLooking+                     }+ mkUnboundNameRdr :: RdrName -> Name mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) +reportUnboundName' :: WhatLooking -> RdrName -> RnM Name+reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr+ reportUnboundName :: RdrName -> RnM Name-reportUnboundName rdr = unboundName WL_Any rdr+reportUnboundName = reportUnboundName' WL_Anything -unboundName :: WhereLooking -> RdrName -> RnM Name-unboundName wl rdr = unboundNameX wl rdr Outputable.empty+unboundName :: LookingFor -> RdrName -> RnM Name+unboundName lf rdr = unboundNameX lf rdr Outputable.empty -unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name-unboundNameX where_look rdr_name extra+unboundNameX :: LookingFor -> RdrName -> SDoc -> RnM Name+unboundNameX looking_for rdr_name extra   = do  { dflags <- getDynFlags         ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags-              err = notInScopeErr rdr_name $$ extra+              err = notInScopeErr (lf_where looking_for) rdr_name $$ extra         ; if not show_helpful_errors           then addErr err           else do { local_env  <- getLocalRdrEnv@@ -80,18 +107,19 @@                   ; impInfo <- getImports                   ; currmod <- getModule                   ; hpt <- getHpt-                  ; let suggestions = unknownNameSuggestions_ where_look+                  ; let suggestions = unknownNameSuggestions_ looking_for                           dflags hpt currmod global_env local_env impInfo                           rdr_name                   ; addErr (err $$ suggestions) }         ; return (mkUnboundNameRdr rdr_name) } -notInScopeErr :: RdrName -> SDoc-notInScopeErr rdr_name-  = case isExact_maybe rdr_name of-      Just name -> exactNameErr name-      Nothing -> hang (text "Not in scope:")-                  2 (what <+> quotes (ppr rdr_name))+notInScopeErr :: WhereLooking -> RdrName -> SDoc+notInScopeErr where_look rdr_name+  | Just name <- isExact_maybe rdr_name = exactNameErr name+  | WL_LocalTop <- where_look = hang (text "No top-level binding for")+      2 (what <+> quotes (ppr rdr_name) <+> text "in this module")+  | otherwise = hang (text "Not in scope:")+                 2 (what <+> quotes (ppr rdr_name))   where     what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) @@ -101,20 +129,20 @@   -- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable-unknownNameSuggestions :: DynFlags+unknownNameSuggestions :: WhatLooking -> DynFlags                        -> HomePackageTable -> Module                        -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails                        -> RdrName -> SDoc-unknownNameSuggestions = unknownNameSuggestions_ WL_Any+unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere) -unknownNameSuggestions_ :: WhereLooking -> DynFlags+unknownNameSuggestions_ :: LookingFor -> DynFlags                        -> HomePackageTable -> Module                        -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails                        -> RdrName -> SDoc-unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env+unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env                           imports tried_rdr_name =-    similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$-    importSuggestions where_look global_env hpt+    similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name $$+    importSuggestions looking_for global_env hpt                       curr_mod imports tried_rdr_name $$     extensionSuggestions tried_rdr_name $$     fieldSelectorSuggestions global_env tried_rdr_name@@ -138,11 +166,11 @@           | otherwise    = text "belonging to the type" <> plural parents                              <+> pprQuotedList parents -similarNameSuggestions :: WhereLooking -> DynFlags-                        -> GlobalRdrEnv -> LocalRdrEnv-                        -> RdrName -> SDoc-similarNameSuggestions where_look dflags global_env-                        local_env tried_rdr_name+similarNameSuggestions :: LookingFor -> DynFlags+                       -> GlobalRdrEnv -> LocalRdrEnv+                       -> RdrName -> SDoc+similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env+                       local_env tried_rdr_name   = case suggest of       []  -> Outputable.empty       [p] -> perhaps <+> pp_item p@@ -150,10 +178,11 @@                  , nest 2 (pprWithCommas pp_item ps) ]   where     all_possibilities :: [(String, (RdrName, HowInScope))]-    all_possibilities-       =  [ (showPpr dflags r, (r, Left loc))-          | (r,loc) <- local_possibilities local_env ]-       ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]+    all_possibilities = case what_look of+      WL_None -> []+      _ -> [ (showPpr dflags r, (r, Left loc))+           | (r,loc) <- local_possibilities local_env ]+        ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]      suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities     perhaps = text "Perhaps you meant"@@ -176,15 +205,17 @@     tried_ns      = occNameSpace tried_occ     tried_is_qual = isQual tried_rdr_name -    correct_name_space occ =  nameSpacesRelated (occNameSpace occ) tried_ns-                           && isSymOcc occ == tried_is_sym+    correct_name_space occ =+      (nameSpacesRelated dflags what_look tried_ns (occNameSpace occ))+      && isSymOcc occ == tried_is_sym         -- Treat operator and non-operators as non-matching         -- This heuristic avoids things like         --      Not in scope 'f'; perhaps you meant '+' (from Prelude) -    local_ok = case where_look of { WL_Any -> True+    local_ok = case where_look of { WL_Anywhere  -> True                                   ; WL_LocalOnly -> True-                                  ; _ -> False }+                                  ; _            -> False }+     local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]     local_possibilities env       | tried_is_qual = []@@ -198,8 +229,7 @@     global_possibilities global_env       | tried_is_qual = [ (rdr_qual, (rdr_qual, how))                         | gre <- globalRdrEnvElts global_env-                        , isGreOk where_look gre-                        , not (isNoFieldSelectorGRE gre)+                        , isGreOk looking_for gre                         , let occ = greOccName gre                         , correct_name_space occ                         , (mod, how) <- qualsInScope gre@@ -207,8 +237,7 @@        | otherwise = [ (rdr_unqual, pair)                     | gre <- globalRdrEnvElts global_env-                    , isGreOk where_look gre-                    , not (isNoFieldSelectorGRE gre)+                    , isGreOk looking_for gre                     , let occ = greOccName gre                           rdr_unqual = mkRdrUnqual occ                     , correct_name_space occ@@ -244,12 +273,13 @@         | i <- is, let ispec = is_decl i, is_qual ispec ]  -- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.-importSuggestions :: WhereLooking+importSuggestions :: LookingFor                   -> GlobalRdrEnv                   -> HomePackageTable -> Module                   -> ImportAvails -> RdrName -> SDoc-importSuggestions where_look global_env hpt currMod imports rdr_name-  | WL_LocalOnly <- where_look                 = Outputable.empty+importSuggestions looking_for global_env hpt currMod imports rdr_name+  | WL_LocalOnly <- lf_where looking_for       = Outputable.empty+  | WL_LocalTop  <- lf_where looking_for       = Outputable.empty   | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty   | null interesting_imports   , Just name <- mod_name@@ -352,7 +382,8 @@   -- wouldn't have an out-of-scope error in the first place)   helpful_imports = filter helpful interesting_imports     where helpful (_,imv)-            = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name+            = any (isGreOk looking_for) $+              lookupGlobalRdrEnv (imv_all_exports imv) occ_name    -- Which of these do that because of an explicit hiding list resp. an   -- explicit import list@@ -362,7 +393,7 @@   -- See note [When to show/hide the module-not-imported line]   show_not_imported_line :: ModuleName -> Bool                    -- #15611   show_not_imported_line modnam-      | modnam `elem` globMods                = False    -- #14225     -- 1+      | modnam `elem` glob_mods               = False    -- #14225     -- 1       | moduleName currMod == modnam          = False                  -- 2.1       | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2       | otherwise                             = True@@ -370,9 +401,8 @@       hpt_uniques = map fst (udfmToList hpt)       is_last_loaded_mod _ []         = False       is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam-      globMods = nub [ mod+      glob_mods = nub [ mod                      | gre <- globalRdrEnvElts global_env-                     , isGreOk where_look gre                      , (mod, _) <- qualsInScope gre                      ] @@ -392,13 +422,76 @@       | otherwise = [ (is_as ispec, Right ispec)                     | i <- is, let ispec = is_decl i ] -isGreOk :: WhereLooking -> GlobalRdrElt -> Bool-isGreOk where_look = case where_look of-                         WL_LocalTop  -> isLocalGRE-                         WL_LocalOnly -> const False-                         _            -> const True+isGreOk :: LookingFor -> GlobalRdrElt -> Bool+isGreOk (LF what_look where_look) gre = what_ok && where_ok+  where+    -- when looking for record fields, what_ok checks whether the GRE is a+    -- record field. Otherwise, it checks whether the GRE is a record field+    -- defined in a module with -XNoFieldSelectors - it wouldn't be a useful+    -- suggestion in that case.+    what_ok  = case what_look of+                 WL_RecField -> isRecFldGRE gre+                 _           -> not (isNoFieldSelectorGRE gre) -{- Note [When to show/hide the module-not-imported line]           -- #15611+    where_ok = case where_look of+                 WL_LocalTop  -> isLocalGRE gre+                 WL_LocalOnly -> False+                 _            -> True++-- see Note [Related name spaces]+nameSpacesRelated :: DynFlags    -- ^ to find out whether -XDataKinds is enabled+                  -> WhatLooking -- ^ What kind of name are we looking for+                  -> NameSpace   -- ^ Name space of the original name+                  -> NameSpace   -- ^ Name space of a name that might have been meant+                  -> Bool+nameSpacesRelated dflags what_looking ns ns'+  = ns' `elem` ns : [ other_ns+                    | (orig_ns, others) <- other_namespaces+                    , ns == orig_ns+                    , (other_ns, wls) <- others+                    , what_looking `elem` WL_Anything : wls+                    ]+  where+    -- explanation:+    -- [(orig_ns, [(other_ns, what_looking_possibilities)])]+    -- A particular other_ns is related if the original namespace is orig_ns+    -- and what_looking is either WL_Anything or is one of+    -- what_looking_possibilities+    other_namespaces =+      [ (varName  , [(dataName, [WL_Constructor])])+      , (dataName , [(varName , [WL_RecField])])+      , (tvName   , (tcClsName, [WL_Constructor]) : promoted_datacons)+      , (tcClsName, (tvName   , []) : promoted_datacons)+      ]+    -- If -XDataKinds is enabled, the data constructor name space is also+    -- related to the type-level name spaces+    data_kinds = xopt LangExt.DataKinds dflags+    promoted_datacons = [(dataName, [WL_Constructor]) | data_kinds]++{-+Note [Related name space]+~~~~~~~~~~~~~~~~~~~~~~~~~+Name spaces are related if there is a chance to mean the one when one writes+the other, i.e. variables <-> data constructors and type variables <-> type+constructors.++In most contexts, this mistake can happen in both directions. Not so in+patterns:++When a user writes+        foo (just a) = ...+It is possible that they meant to use `Just` instead. However, when they write+        foo (Map a) = ...+It is unlikely that they mean to use `map`, since variables cannot be used here.++Similarly, when we look for record fields, data constructors are not in a+related namespace.++Furthermore, with -XDataKinds, the data constructor name space is related to+the type variable and type constructor name spaces.++Note [When to show/hide the module-not-imported line]           -- #15611+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the error message:     Not in scope X.Y     Module X does not export Y
compiler/GHC/Runtime/Eval.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -44,8 +44,6 @@         Term(..), obtainTermFromId, obtainTermFromVal, reconstructType         ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Monad@@ -667,7 +665,7 @@              Just new_ty -> do               case improveRTTIType hsc_env old_ty new_ty of                Nothing -> return $-                        WARN(True, text (":print failed to calculate the "+                        warnPprTrace True (text (":print failed to calculate the "                                            ++ "improvement for a type")) hsc_env                Just subst -> do                  let dflags = hsc_dflags hsc_env
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-}+{-# LANGUAGE BangPatterns, ScopedTypeVariables, MagicHash #-}  ----------------------------------------------------------------------------- --@@ -23,8 +23,6 @@      constrClosToName -- exported to use in test T4891  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -60,6 +58,7 @@ import GHC.Driver.Ppr import GHC.Utils.Outputable as Ppr import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Char import GHC.Exts.Heap import GHC.Runtime.Heap.Layout ( roundUpTo )@@ -267,17 +266,16 @@ ppr_termM1 Prim{valRaw=words, ty=ty} =     return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =-    return (char '_' <+> whenPprDebug (dcolon <> ppr ty))+    return (char '_' <+> whenPprDebug (dcolon <> pprSigmaType ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n}---  | Just _ <- splitFunTy_maybe ty = return$ text "<function>"-  | otherwise = return$ parens$ ppr n <> dcolon <> ppr ty+  | otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType ty ppr_termM1 Term{}        = panic "ppr_termM1 - Term" ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap" ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"  pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}   | Just (tc,_) <- tcSplitTyConApp_maybe ty-  , ASSERT(isNewTyCon tc) True+  , assert (isNewTyCon tc) True   , Just new_dc <- tyConSingleDataCon_maybe tc = do              real_term <- y max_prec t              return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)@@ -606,7 +604,8 @@ This allows metavariables to unify with types that have nested (or higher-rank) `forall`s/`=>`s, which makes `:print fmap` display as-`fmap = (_t1::forall a b. Functor f => (a -> b) -> f a -> f b)`, as expected.+`fmap = (_t1::forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b)`,+as expected. -}  @@ -690,13 +689,12 @@   -- we quantify existential tyvars as universal,   -- as this is needed to be able to manipulate   -- them properly-   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty-       sigma_old_ty = mkInfForAllTys old_tvs old_tau+   let quant_old_ty@(old_tvs, _) = quantifyType old_ty    traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)    term <-      if null old_tvs       then do-        term  <- go max_depth sigma_old_ty sigma_old_ty hval+        term  <- go max_depth old_ty old_ty hval         term' <- zonkTerm term         return $ fixFunDictionaries $ expandNewtypes term'       else do@@ -704,7 +702,7 @@               my_ty <- newOpenVar               when (check1 quant_old_ty) (traceTR (text "check1 passed") >>                                           addConstraint my_ty old_ty')-              term  <- go max_depth my_ty sigma_old_ty hval+              term  <- go max_depth my_ty old_ty hval               new_ty <- zonkTcType (termType term)               if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty                  then do@@ -734,10 +732,6 @@   unit_env = hsc_unit_env hsc_env    go :: Int -> Type -> Type -> ForeignHValue -> TcM Term-   -- I believe that my_ty should not have any enclosing-   -- foralls, nor any free RuntimeUnk skolems;-   -- that is partly what the quantifyType stuff achieved-   --    -- [SPJ May 11] I don't understand the difference between my_ty and old_ty    go 0 my_ty _old_ty a = do@@ -793,7 +787,7 @@                   -- MutVar# :: contents_ty -> MutVar# s contents_ty          traceTR (text "Following a MutVar")          contents_tv <- newVar liftedTypeKind-         MASSERT(isUnliftedType my_ty)+         massert (isUnliftedType my_ty)          (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany                             contents_ty (mkTyConApp tycon [world,contents_ty])          addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty@@ -913,7 +907,7 @@                      [index size_b aligned_idx word_size endian]                  | otherwise =                      let (q, r) = size_b `quotRem` word_size-                     in ASSERT( r == 0 )+                     in assert (r == 0 )                         [ array!!i                         | o <- [0.. q - 1]                         , let i = (aligned_idx `quot` word_size) + o@@ -1080,13 +1074,11 @@ -- return the types of the arguments.  This is RTTI-land, so 'ty' might -- not be fully known.  Moreover, the arg types might involve existentials; -- if so, make up fresh RTTI type variables for them------ I believe that con_app_ty should not have any enclosing foralls getDataConArgTys dc con_app_ty   = do { let rep_con_app_ty = unwrapType con_app_ty        ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty                    $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))-       ; ASSERT( all isTyVar ex_tvs ) return ()+       ; assert (all isTyVar ex_tvs ) return ()                  -- ex_tvs can only be tyvars as data types in source                  -- Haskell cannot mention covar yet (Aug 2018)        ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)@@ -1384,18 +1376,12 @@  type QuantifiedType = ([TyVar], Type)    -- Make the free type variables explicit-   -- The returned Type should have no top-level foralls (I believe)  quantifyType :: Type -> QuantifiedType--- Generalize the type: find all free and forall'd tyvars--- and return them, together with the type inside, which--- should not be a forall type.------ Thus (quantifyType (forall a. a->[b]))--- returns ([a,b], a -> [b])-+-- Find all free and forall'd tyvars and return them+-- together with the unmodified input type. quantifyType ty = ( filter isTyVar $                     tyCoVarsOfTypeWellScoped rho-                  , rho)+                  , ty)   where-    (_tvs, rho) = tcSplitForAllInvisTyVars ty+    (_tvs, _, rho) = tcSplitNestedSigmaTys ty
compiler/GHC/Runtime/Loader.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+  -- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader (
compiler/GHC/Settings/IO.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -6,8 +6,6 @@  ( SettingsError (..)  , initSettings  ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Stg/DepAnal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+  module GHC.Stg.DepAnal (depSortStgPgm) where
compiler/GHC/Stg/Lift.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | Implements a selective lambda lifter, running late in the optimisation -- pipeline. --@@ -15,8 +15,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Basic@@ -28,7 +26,6 @@ import GHC.Stg.Syntax import GHC.Utils.Outputable import GHC.Types.Unique.Supply-import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Types.Var.Set import Control.Monad ( when )@@ -200,7 +197,9 @@   -> LlStgRhs   -> LiftM OutStgRhs liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args)-  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs)+  = assertPpr (isNothing mb_former_fvs)+              (text "Should never lift a constructor"+               $$ pprStgRhs panicStgPprOpts rhs) $     StgRhsCon ccs con mn ts <$> traverse liftArgs args liftRhs Nothing (StgRhsClosure _ ccs upd infos body) =   -- This RHS wasn't lifted.@@ -215,7 +214,7 @@ liftArgs :: InStgArg -> LiftM OutStgArg liftArgs a@(StgLitArg _) = pure a liftArgs (StgVarArg occ) = do-  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )+  assertPprM (not <$> isLifted occ) (text "StgArgs should never be lifted" $$ ppr occ)   StgVarArg <$> substOcc occ  liftExpr :: LlStgExpr -> LiftM OutStgExpr
compiler/GHC/Stg/Lift/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -20,8 +20,6 @@     substOcc, isLifted, formerFreeVars, liftedIdsExpander   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Basic@@ -36,8 +34,8 @@ import GHC.Stg.Syntax import GHC.Core.Utils import GHC.Types.Unique.Supply-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Multiplicity@@ -183,7 +181,7 @@      map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding     rm_cccs = map_rhss removeRhsCCCS-    merge_binds binds = ASSERT( any is_rec binds )+    merge_binds binds = assert (any is_rec binds) $                         StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)     is_rec StgRec{} = True     is_rec _ = False
compiler/GHC/Stg/Pipeline.hs view
@@ -4,14 +4,12 @@ \section[SimplStg]{Driver for simplifying @STG@ programs} -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}  module GHC.Stg.Pipeline ( stg2stg ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Stg/Stats.hs view
@@ -21,11 +21,9 @@ \end{enumerate} -} -{-# LANGUAGE CPP #-} -module GHC.Stg.Stats ( showStgStats ) where -#include "GhclibHsVersions.h"+module GHC.Stg.Stats ( showStgStats ) where  import GHC.Prelude
compiler/GHC/Stg/Subst.hs view
@@ -1,8 +1,6 @@-{-# LANGUAGE CPP #-} -module GHC.Stg.Subst where -#include "GhclibHsVersions.h"+module GHC.Stg.Subst where  import GHC.Prelude @@ -57,8 +55,7 @@   | not (isLocalId id) = id   | Just id' <- lookupVarEnv env id = id'   | Just id' <- lookupInScope in_scope id = id'-  | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope)-                id+  | otherwise = warnPprTrace True (text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope) id  -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. Does not generate a debug warning if the identifier to@@ -80,5 +77,5 @@ -- holds after extending the substitution like this. extendSubst :: Id -> Id -> Subst -> Subst extendSubst id new_id (Subst in_scope env)-  = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope )+  = assertPpr (new_id `elemInScopeSet` in_scope) (ppr id <+> ppr new_id $$ ppr in_scope) $     Subst in_scope (extendVarEnv env id new_id)
compiler/GHC/Stg/Unarise.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections    #-} @@ -241,8 +241,6 @@  module GHC.Stg.Unarise (unarise) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Basic@@ -257,6 +255,7 @@ import GHC.Utils.Monad (mapAccumLM) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Core.Type@@ -307,10 +306,10 @@ -- | Extend the environment, checking the UnariseEnv invariant. extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv extendRho rho x (MultiVal args)-  = ASSERT(all (isNvUnaryType . stgArgType) args)+  = assert (all (isNvUnaryType . stgArgType) args)     extendVarEnv rho x (MultiVal args) extendRho rho x (UnaryVal val)-  = ASSERT(isNvUnaryType (stgArgType val))+  = assert (isNvUnaryType (stgArgType val))     extendVarEnv rho x (UnaryVal val)  --------------------------------------------------------------------------------@@ -336,7 +335,7 @@        return (StgRhsClosure ext ccs update_flag args1 expr')  unariseRhs rho (StgRhsCon ccs con mu ts args)-  = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))+  = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))     return (StgRhsCon ccs con mu ts (unariseConArgs rho args))  --------------------------------------------------------------------------------@@ -420,7 +419,7 @@   = Just (unariseConArgs rho args)    | isUnboxedSumDataCon dc-  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)+  , let args1 = assert (isSingleton args) (unariseConArgs rho args)   = Just (mkUbxSum dc ty_args args1)    | otherwise@@ -454,7 +453,7 @@              | isUnboxedTupleBndr bndr              = mapTupleIdBinders bndrs args rho1              | otherwise-             = ASSERT(isUnboxedSumBndr bndr)+             = assert (isUnboxedSumBndr bndr) $                if null bndrs then rho1                              else mapSumIdBinders bndrs args rho1 @@ -489,7 +488,7 @@ unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]   | isUnboxedTupleBndr bndr   = do (rho', ys1) <- unariseConArgBinders rho ys-       MASSERT(ys1 `lengthIs` n)+       massert (ys1 `lengthIs` n)        let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))        e' <- unariseExpr rho'' e        return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]@@ -559,7 +558,7 @@   -> UnariseEnv   -> UnariseEnv mapTupleIdBinders ids args0 rho0-  = ASSERT(not (any (isVoidTy . stgArgType) args0))+  = assert (not (any (isVoidTy . stgArgType) args0)) $     let       ids_unarised :: [(Id, [PrimRep])]       ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids@@ -570,12 +569,12 @@         let           x_arity = length x_reps           (x_args, args') =-            ASSERT(args `lengthAtLeast` x_arity)+            assert (args `lengthAtLeast` x_arity)             splitAt x_arity args            rho'             | x_arity == 1-            = ASSERT(x_args `lengthIs` 1)+            = assert (x_args `lengthIs` 1)               extendRho rho x (UnaryVal (head x_args))             | otherwise             = extendRho rho x (MultiVal x_args)@@ -593,7 +592,7 @@   -> UnariseEnv  mapSumIdBinders [id] args rho0-  = ASSERT(not (any (isVoidTy . stgArgType) args))+  = assert (not (any (isVoidTy . stgArgType) args)) $     let       arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args       id_slots  = map primRepSlot $ typePrimRep (idType id)@@ -601,7 +600,7 @@     in       if isMultiValBndr id         then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])-        else ASSERT(layout1 `lengthIs` 1)+        else assert (layout1 `lengthIs` 1)              extendRho rho0 id (UnaryVal (args !! head layout1))  mapSumIdBinders ids sum_args _@@ -787,7 +786,7 @@   | Just as <- unariseRubbish_maybe lit   = as   | otherwise-  = ASSERT(not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals+  = assert (not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals     [arg]  unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
compiler/GHC/StgToByteCode.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                        #-}+ {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards            #-}@@ -13,8 +13,6 @@ -- | GHC.StgToByteCode: Generate bytecode from STG module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen, stgExprToBCOs ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -60,6 +58,8 @@ import GHC.Builtin.Utils ( primOpId ) import GHC.Data.FastString import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Exception (evaluate) import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)@@ -78,7 +78,6 @@ import GHC.Types.Unique.Supply import GHC.Unit.Module -import Control.Exception import Data.Array import Data.Coerce (coerce) import Data.ByteString (ByteString)@@ -633,7 +632,7 @@         (tuple_info, tuple_components) = layoutTuple profile d arg_ty es         go _   pushes [] = return (reverse pushes)         go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a-                                         MASSERT(off == dd + szb)+                                         massert (off == dd + szb)                                          go (dd + szb) (push:pushes) cs     pushes <- go d [] tuple_components     ret <- returnUnboxedReps d@@ -760,7 +759,7 @@ -- See Note [Not-necessarily-lifted join points] protectNNLJoinPointId :: Id -> Id protectNNLJoinPointId x-  = ASSERT( isNNLJoinPoint x )+  = assert (isNNLJoinPoint x )     updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x  {-@@ -949,10 +948,10 @@    do_pushes init_d args (map (atomRep platform) args)   where   do_pushes !d [] reps = do-        ASSERT( null reps ) return ()+        assert (null reps ) return ()         (push_fn, sz) <- pushAtom d p (StgVarArg fn)         platform <- profilePlatform <$> getProfile-        ASSERT( sz == wordSize platform ) return ()+        assert (sz == wordSize platform ) return ()         let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)         return (push_fn `appOL` (slide `appOL` unitOL ENTER))   do_pushes !d args reps = do@@ -1134,7 +1133,7 @@                         | (NonVoid arg, offset) <- args_offsets ]                         p_alts              in do-             MASSERT(isAlgCase)+             massert isAlgCase              rhs_code <- schemeE stack_bot s p' rhs              return (my_discr alt,                      unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)@@ -1263,28 +1262,31 @@       orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos]        -- sort the register parameters by register and add them to the stack+      regs_order :: Map.Map GlobalReg Int+      regs_order = Map.fromList $ zip (tupleRegsCover platform) [0..]++      reg_order :: GlobalReg -> (Int, GlobalReg)+      reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg)+      -- a VanillaReg goes to the same place regardless of whether it+      -- contains a pointer+      reg_order (VanillaReg n VNonGcPtr) = reg_order (VanillaReg n VGcPtr)+      -- if we don't have a position for a FloatReg then they must be passed+      -- in the equivalent DoubleReg+      reg_order (FloatReg n) = reg_order (DoubleReg n)+      -- one-tuples can be passed in other registers, but then we don't need+      -- to care about the order+      reg_order reg          = (0, reg)+       (regs, reg_params)           = unzip $ sortBy (comparing fst)-                           [(reg, x) | (x, RegisterParam reg) <- pos]+                           [(reg_order reg, x) | (x, RegisterParam reg) <- pos]        (new_stk_bytes, new_stk_params) = assignStack platform                                                     orig_stk_bytes                                                     arg_ty                                                     reg_params -      -- make live register bitmaps-      bmp_reg r ~(v, f, d, l)-        = case r of VanillaReg n _ -> (a v n, f,     d,     l    )-                    FloatReg n     -> (v,     a f n, d,     l    )-                    DoubleReg n    -> (v,     f,     a d n, l    )-                    LongReg n      -> (v,     f,     d,     a l n)-                    _              ->-                      pprPanic "GHC.StgToByteCode.layoutTuple unsupported register type"-                               (ppr r)-              where a bmp n = bmp .|. (1 `shiftL` (n-1))--      (vanilla_regs, float_regs, double_regs, long_regs)-          = foldr bmp_reg (0, 0, 0, 0) regs+      regs_set = mkRegSet (map snd regs)        get_byte_off (x, StackParam y) = (x, fromIntegral y)       get_byte_off _                 =@@ -1292,10 +1294,7 @@    in ( TupleInfo          { tupleSize        = bytesToWords platform (ByteOff new_stk_bytes)-         , tupleVanillaRegs = vanilla_regs-         , tupleLongRegs    = long_regs-         , tupleFloatRegs   = float_regs-         , tupleDoubleRegs  = double_regs+         , tupleRegs        = regs_set          , tupleNativeStackSize = bytesToWords platform                                                (ByteOff orig_stk_bytes)          }@@ -1645,7 +1644,9 @@      AddrRep     -> FFIPointer      FloatRep    -> FFIFloat      DoubleRep   -> FFIDouble-     _           -> panic "primRepToFFIType"+     LiftedRep   -> FFIPointer+     UnliftedRep -> FFIPointer+     _           -> pprPanic "primRepToFFIType" (ppr r)   where     (signed_word, unsigned_word) = case platformWordSize platform of        PW4 -> (FFISInt32, FFIUInt32)@@ -1656,19 +1657,21 @@ mkDummyLiteral :: Platform -> PrimRep -> Literal mkDummyLiteral platform pr    = case pr of-        IntRep    -> mkLitInt  platform 0-        WordRep   -> mkLitWord platform 0-        Int8Rep   -> mkLitInt8 0-        Word8Rep  -> mkLitWord8 0-        Int16Rep  -> mkLitInt16 0-        Word16Rep -> mkLitWord16 0-        Int32Rep  -> mkLitInt32 0-        Word32Rep -> mkLitWord32 0-        Int64Rep  -> mkLitInt64 0-        Word64Rep -> mkLitWord64 0-        AddrRep   -> LitNullAddr-        DoubleRep -> LitDouble 0-        FloatRep  -> LitFloat 0+        IntRep      -> mkLitInt  platform 0+        WordRep     -> mkLitWord platform 0+        Int8Rep     -> mkLitInt8 0+        Word8Rep    -> mkLitWord8 0+        Int16Rep    -> mkLitInt16 0+        Word16Rep   -> mkLitWord16 0+        Int32Rep    -> mkLitInt32 0+        Word32Rep   -> mkLitWord32 0+        Int64Rep    -> mkLitInt64 0+        Word64Rep   -> mkLitWord64 0+        AddrRep     -> LitNullAddr+        DoubleRep   -> LitDouble 0+        FloatRep    -> LitFloat 0+        LiftedRep   -> LitNullAddr+        UnliftedRep -> LitNullAddr         _         -> pprPanic "mkDummyLiteral" (ppr pr)  @@ -1699,9 +1702,7 @@        case r_reps of          []            -> panic "empty typePrimRepArgs"          [VoidRep]     -> Nothing-         [rep]-           | isGcPtrRep rep -> blargh-           | otherwise      -> Just rep+         [rep]         -> Just rep                   -- if it was, it would be impossible to create a                  -- valid return value placeholder on the stack@@ -1770,7 +1771,7 @@     -> BcM BCInstrList -- See Note [Implementing tagToEnum#] implement_tagToId d s p arg names-  = ASSERT( notNull names )+  = assert (notNull names) $     do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)        labels <- getLabelsBc (genericLength names)        label_fail <- getLabelBc@@ -1863,7 +1864,7 @@               fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr             Nothing -> do                 let sz = idSizeCon platform var-                MASSERT( sz == wordSize platform )+                massert (sz == wordSize platform)                 return (unitOL (PUSH_G (getName var)), sz)
compiler/GHC/StgToCmm.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DataKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-}@@ -13,8 +13,6 @@  module GHC.StgToCmm ( codeGen ) where -#include "GhclibHsVersions.h"- import GHC.Prelude as Prelude  import GHC.Driver.Backend@@ -59,7 +57,7 @@  import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger  import GHC.Utils.TmpFs@@ -224,7 +222,7 @@       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise  cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)-  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables+  = assert (isEmptyDVarSet fvs)    -- There should be no free variables     cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body  @@ -262,7 +260,7 @@ -- Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor. cgDataCon mn data_con-  = do  { MASSERT( not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con) )+  = do  { massert (not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con))         ; profile <- getProfile         ; platform <- getPlatform         ; let
compiler/GHC/StgToCmm/Bind.hs view
@@ -285,7 +285,7 @@   , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset                           - fixedHdrSizeW profile   , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough-  = -- NOT TRUE: ASSERT(is_single_constructor)+  = -- NOT TRUE: assert (is_single_constructor)     -- The simplifier may have statically determined that the single alternative     -- is the only possible case and eliminated the others, even if there are     -- other constructors in the datatype.  It's still ok to make a selector
compiler/GHC/StgToCmm/Closure.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -68,8 +68,6 @@         staticClosureNeedsLink,     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.Platform.Profile@@ -96,6 +94,7 @@ import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.Coerce (coerce)@@ -158,7 +157,7 @@ -- non-void; e.g. constructor field binders in case expressions. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidIds :: [Id] -> [NonVoid Id]-assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))+assertNonVoidIds ids = assert (not (any (isVoidTy . idType) ids)) $                        coerce ids  nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]@@ -168,7 +167,7 @@ -- non-void; e.g. constructor arguments. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))+assertNonVoidStgArgs args = assert (not (any (isVoidTy . stgArgType) args)) $                             coerce args  @@ -233,7 +232,7 @@ ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo mkLFThunk thunk_ty top fvs upd_flag-  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )+  = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $     LFThunk top (null fvs)             (isUpdatable upd_flag)             NonStandardThunk@@ -529,15 +528,15 @@   | n_args == 0 -- No args at all   && not (profileIsProfiling (co_profile opts))      -- See Note [Evaluating functions with profiling] in rts/Apply.cmm-  = ASSERT( arity /= 0 ) ReturnIt+  = assert (arity /= 0) ReturnIt   | n_args < arity = SlowCall        -- Not enough args   | otherwise      = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity  getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt+  = assert (n_args == 0) ReturnIt  getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt+  = assert (n_args == 0) ReturnIt     -- n_args=0 because it'd be ill-typed to apply a saturated     --          constructor application to anything @@ -561,7 +560,7 @@   | SelectorThunk{} <- std_form_info   = EnterIt -    -- We used to have ASSERT( n_args == 0 ), but actually it is+    -- We used to have assert (n_args == 0 ), but actually it is     -- possible for the optimiser to generate     --   let bot :: Int = error Int "urk"     --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3@@ -569,7 +568,7 @@     -- So the right thing to do is just to enter the thing    | otherwise        -- Jump direct to code for single-entry thunks-  = ASSERT( n_args == 0 )+  = assert (n_args == 0) $     DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info                 updatable) 0 @@ -577,7 +576,7 @@   = SlowCall -- might be a function  getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info-  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )+  = assertPpr (n_args == 0) (ppr name <+> ppr n_args)     EnterIt -- Not a function  getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
compiler/GHC/StgToCmm/DataCon.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C--: code generation for constructors@@ -15,8 +15,6 @@         cgTopRhsCon, buildDynCon, bindConArgs     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -49,6 +47,7 @@ import GHC.Types.Literal import GHC.Builtin.Utils import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM) @@ -93,8 +92,8 @@         ; this_mod <- getModuleName         ; when (platformOS platform == OSMinGW32) $               -- Windows DLLs have a problem with static cross-DLL refs.-              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )-        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()+              massert (not (isDllConApp dflags this_mod con (map fromNonVoid args)))+        ; assert (args `lengthIs` countConRepArgs con ) return ()          -- LAY IT OUT         ; let@@ -382,7 +381,7 @@ -- binders args, assuming that we have just returned from a 'case' which -- found a con bindConArgs (DataAlt con) base args-  = ASSERT(not (isUnboxedTupleDataCon con))+  = assert (not (isUnboxedTupleDataCon con)) $     do profile <- getProfile        platform <- getPlatform        let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)@@ -402,4 +401,4 @@        mapMaybeM bind_arg args_w_offsets  bindConArgs _other_con _base args-  = ASSERT( null args ) return []+  = assert (null args ) return []
compiler/GHC/StgToCmm/Env.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: the binding environment@@ -21,8 +21,6 @@         maybeLetNoEscape,     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -42,9 +40,9 @@ import GHC.Types.Unique.FM import GHC.Types.Var.Env -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Driver.Session @@ -137,7 +135,7 @@                       | isUnliftedType (idType id)                           -- An unlifted external Id must refer to a top-level                           -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".-                      = ASSERT( idType id `eqType` addrPrimTy )+                      = assert (idType id `eqType` addrPrimTy) $                         mkBytesLabel name                       | otherwise                       = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))
compiler/GHC/StgToCmm/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -12,8 +12,6 @@  module GHC.StgToCmm.Expr ( cgExpr, cgLit ) where -#include "GhclibHsVersions.h"- import GHC.Prelude hiding ((<*>))  import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind )@@ -53,6 +51,7 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad ( unless, void ) import Control.Arrow ( first )@@ -555,7 +554,7 @@   = assertNonVoidIds [bndr]  chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]-  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)+  = assertPpr (ids `lengthIs` n) (ppr n $$ ppr ids $$ ppr _bndr) $     assertNonVoidIds ids     -- 'bndr' is not assigned!  chooseReturnBndrs bndr (AlgAlt _) _alts@@ -872,7 +871,8 @@        ; emitReturn arg_exprs }    | otherwise   --  Boxed constructors; allocate and return-  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )+  = assertPpr (stg_args `lengthIs` countConRepArgs con)+              (ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args) $     do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) mn False                                      currentCCS con (assertNonVoidStgArgs stg_args)                                      -- con args are always non-void,@@ -904,7 +904,7 @@           | otherwise                -> emitReturn [fun]           -- ToDo: does ReturnIt guarantee tagged? -        EnterIt -> ASSERT( null args )  -- Discarding arguments+        EnterIt -> assert (null args) $  -- Discarding arguments                    emitEnter fun          SlowCall -> do      -- A slow function call via the RTS apply routines
compiler/GHC/StgToCmm/Foreign.hs view
@@ -15,6 +15,8 @@   emitLoadThreadState,   emitSaveRegs,   emitRestoreRegs,+  emitPushTupleRegs,+  emitPopTupleRegs,   loadThreadState,   emitOpenNursery,   emitCloseNursery,@@ -339,6 +341,63 @@    let regs    = realArgRegsCover platform        restore = catAGraphs (map (callerRestoreGlobalReg platform) regs)    emit restore++-- | Push a subset of STG registers onto the stack, specified by the bitmap+--+-- Sometimes, a "live" subset of the STG registers needs to be saved on the+-- stack, for example when storing an unboxed tuple to be used in the GHCi+-- bytecode interpreter.+--+-- The "live registers" bitmap corresponds to the list of registers given by+-- 'tupleRegsCover', with the least significant bit indicating liveness of+-- the first register in the list.+--+-- Each register is saved to a stack slot of one or more machine words, even+-- if the register size itself is smaller.+--+-- The resulting Cmm code looks like this, with a line for each real or+-- virtual register used for returning tuples:+--+--    ...+--    if((mask & 2) != 0) { Sp_adj(-1); Sp(0) = R2; }+--    if((mask & 1) != 0) { Sp_adj(-1); Sp(0) = R1; }+--+-- See Note [GHCi tuple layout]++emitPushTupleRegs :: CmmExpr -> FCode ()+emitPushTupleRegs regs_live = do+  platform <- getPlatform+  let regs = zip (tupleRegsCover platform) [0..]+      save_arg (reg, n) =+        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))+            live     = cmmAndWord platform regs_live mask+            cond     = cmmNeWord platform live (zeroExpr platform)+            reg_ty   = cmmRegType platform (CmmGlobal reg)+            width    = roundUpToWords platform+                                      (widthInBytes $ typeWidth reg_ty)+            adj_sp   = mkAssign spReg+                                (cmmOffset platform spExpr (negate width))+            save_reg = mkStore spExpr (CmmReg $ CmmGlobal reg)+        in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg]+  emit . catAGraphs =<< mapM save_arg (reverse regs)++-- | Pop a subset of STG registers from the stack (see 'emitPushTupleRegs')+emitPopTupleRegs :: CmmExpr -> FCode ()+emitPopTupleRegs regs_live = do+  platform <- getPlatform+  let regs = zip (tupleRegsCover platform) [0..]+      save_arg (reg, n) =+        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))+            live     = cmmAndWord platform regs_live mask+            cond     = cmmNeWord platform live (zeroExpr platform)+            reg_ty   = cmmRegType platform (CmmGlobal reg)+            width    = roundUpToWords platform+                                      (widthInBytes $ typeWidth reg_ty)+            adj_sp   = mkAssign spReg+                                (cmmOffset platform spExpr width)+            restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty)+        in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp]+  emit . catAGraphs =<< mapM save_arg regs   emitCloseNursery :: FCode ()
compiler/GHC/StgToCmm/Layout.hs view
@@ -31,8 +31,6 @@   ) where  -#include "GhclibHsVersions.h"- import GHC.Prelude hiding ((<*>))  import GHC.Driver.Session@@ -65,6 +63,8 @@ import Data.List (mapAccumL, partition) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString import Control.Monad @@ -438,7 +438,7 @@ -- than the unboxed things  mkVirtHeapOffsetsWithPadding profile header things =-    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))+    assert (not (any (isVoidRep . fst . fromNonVoid) things))     ( tot_wds     , bytesToWordsRoundUp platform bytes_of_ptrs     , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
compiler/GHC/StgToCmm/Lit.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, LambdaCase #-}+{-# LANGUAGE LambdaCase #-}  ----------------------------------------------------------------------------- --@@ -12,8 +12,6 @@     cgLit, mkSimpleLit,     newStringCLit, newByteStringCLit   ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/StgToCmm/Monad.hs view
@@ -86,7 +86,7 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn) import GHC.Exts (oneShot)  import Control.Monad
compiler/GHC/StgToCmm/Prim.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -16,8 +16,6 @@    shouldInlinePrimOp  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude hiding ((<*>))  import GHC.Platform@@ -48,6 +46,7 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.Maybe  import Control.Monad (liftM, when, unless)@@ -1522,7 +1521,7 @@     --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#     -- That won't work.     let tycon = tyConAppTyCon res_ty-    MASSERT(isEnumerationTyCon tycon)+    massert (isEnumerationTyCon tycon)     platform <- getPlatform     pure [tagToClosure platform tycon amode] @@ -1620,6 +1619,7 @@   TraceMarkerOp -> alwaysExternal   SetThreadAllocationCounter -> alwaysExternal +  -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.   KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"   where
compiler/GHC/StgToCmm/Utils.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generator utilities; mostly monadic@@ -45,8 +45,6 @@         convertInfoProvMap, cmmInfoTableToInfoProvEnt   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -76,6 +74,7 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Types.CostCentre import GHC.Types.IPE@@ -287,12 +286,12 @@ -- the Sequel.  If the Sequel is a join point, using the -- regs it wants will save later assignments. newUnboxedTupleRegs res_ty-  = ASSERT( isUnboxedTupleType res_ty )+  = assert (isUnboxedTupleType res_ty) $     do  { platform <- getPlatform         ; sequel <- getSequel         ; regs <- choose_regs platform sequel-        ; ASSERT( regs `equalLength` reps )-          return (regs, map primRepForeignHint reps) }+        ; massert (regs `equalLength` reps)+        ; return (regs, map primRepForeignHint reps) }   where     reps = typePrimRep res_ty     choose_regs _ (AssignTo regs _) = return regs@@ -323,7 +322,7 @@ emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs emitMultiAssign regs rhss   = do   platform <- getPlatform-  ASSERT2( equalLength regs rhss, ppr regs $$ pdoc platform rhss )+  assertPpr (equalLength regs rhss) (ppr regs $$ pdoc platform rhss) $     unscramble platform ([1..] `zip` (regs `zip` rhss))  unscramble :: Platform -> [Vrtx] -> FCode ()@@ -411,7 +410,7 @@ -- SINGLETON TAG RANGE: no case analysis to do mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)   | lo_tag == hi_tag-  = ASSERT( tag == lo_tag )+  = assert (tag == lo_tag) $     mkBranch lbl  -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
compiler/GHC/SysTools.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-}  {-@@ -20,7 +20,9 @@         module GHC.SysTools.Tasks,         module GHC.SysTools.Info, -        copy,+        -- * Fast file copy+        copyFile,+        copyHandle,         copyWithHeader,          -- * General utilities@@ -28,27 +30,26 @@         expandTopDir,  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Settings.Utils -import GHC.Utils.Error import GHC.Utils.Panic-import GHC.Utils.Logger import GHC.Driver.Session -import Control.Monad.Trans.Except (runExceptT)-import System.FilePath-import System.IO-import System.IO.Unsafe (unsafeInterleaveIO) import GHC.Linker.ExtraObj import GHC.SysTools.Info import GHC.SysTools.Tasks import GHC.SysTools.BaseDir import GHC.Settings.IO +import Control.Monad.Trans.Except (runExceptT)+import System.FilePath+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO)+import Foreign.Marshal.Alloc (allocaBytes)+import System.Directory (copyFile)+ {- Note [How GHC finds toolchain utilities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -186,26 +187,25 @@  -} -copy :: Logger -> DynFlags -> String -> FilePath -> FilePath -> IO ()-copy logger dflags purpose from to = copyWithHeader logger dflags purpose Nothing from to--copyWithHeader :: Logger -> DynFlags -> String -> Maybe String -> FilePath -> FilePath-               -> IO ()-copyWithHeader logger dflags purpose maybe_header from to = do-  showPass logger dflags purpose+-- | Copy remaining bytes from the first Handle to the second one+copyHandle :: Handle -> Handle -> IO ()+copyHandle hin hout = do+  let buf_size = 8192+  allocaBytes buf_size $ \ptr -> do+    let go = do+          c <- hGetBuf hin ptr buf_size+          hPutBuf hout ptr c+          if c == 0 then return () else go+    go -  hout <- openBinaryFile to   WriteMode-  hin  <- openBinaryFile from ReadMode-  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up-  maybe (return ()) (header hout) maybe_header-  hPutStr hout ls-  hClose hout-  hClose hin- where-  -- write the header string in UTF-8.  The header is something like-  --   {-# LINE "foo.hs" #-}-  -- and we want to make sure a Unicode filename isn't mangled.-  header h str = do-   hSetEncoding h utf8-   hPutStr h str-   hSetBinaryMode h True+-- | Copy file after printing the given header+copyWithHeader :: String -> FilePath -> FilePath -> IO ()+copyWithHeader header from to =+  withBinaryFile to WriteMode $ \hout -> do+    -- write the header string in UTF-8.  The header is something like+    --   {-# LINE "foo.hs" #-}+    -- and we want to make sure a Unicode filename isn't mangled.+    hSetEncoding hout utf8+    hPutStr hout header+    withBinaryFile from ReadMode $ \hin ->+      copyHandle hin hout
compiler/GHC/SysTools/Ar.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} {- Note: [The need for Ar.hs] Building `-staticlib` required the presence of libtool, and was a such restricted to mach-o only. As libtool on macOS and gnu libtool are very
compiler/GHC/SysTools/Info.hs view
@@ -205,22 +205,34 @@         return UnknownLD     ) --- Grab compiler info and cache it in DynFlags.+-- | Grab compiler info and cache it in DynFlags. getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo getCompilerInfo logger dflags = do   info <- readIORef (rtccInfo dflags)   case info of     Just v  -> return v     Nothing -> do-      v <- getCompilerInfo' logger dflags+      let pgm = pgm_c dflags+      v <- getCompilerInfo' logger dflags pgm       writeIORef (rtccInfo dflags) (Just v)       return v +-- | Grab assembler info and cache it in DynFlags.+getAssemblerInfo :: Logger -> DynFlags -> IO CompilerInfo+getAssemblerInfo logger dflags = do+  info <- readIORef (rtasmInfo dflags)+  case info of+    Just v  -> return v+    Nothing -> do+      let (pgm, _) = pgm_a dflags+      v <- getCompilerInfo' logger dflags pgm+      writeIORef (rtasmInfo dflags) (Just v)+      return v+ -- See Note [Run-time linker info].-getCompilerInfo' :: Logger -> DynFlags -> IO CompilerInfo-getCompilerInfo' logger dflags = do-  let pgm = pgm_c dflags-      -- Try to grab the info from the process output.+getCompilerInfo' :: Logger -> DynFlags -> String -> IO CompilerInfo+getCompilerInfo' logger dflags pgm = do+  let -- Try to grab the info from the process output.       parseCompilerInfo _stdo stde _exitc         -- Regular GCC         | any ("gcc version" `isInfixOf`) stde =@@ -240,8 +252,8 @@         -- Xcode 4.1 clang         | any ("Apple clang version" `isPrefixOf`) stde =           return AppleClang-         -- Unknown linker.-        | otherwise = fail $ "invalid -v output, or compiler is unsupported: " ++ unlines stde+         -- Unknown compiler.+        | otherwise = fail $ "invalid -v output, or compiler is unsupported (" ++ pgm ++ "): " ++ unlines stde    -- Process the executable call   catchIO (do
compiler/GHC/SysTools/Process.hs view
@@ -8,8 +8,6 @@ ----------------------------------------------------------------------------- module GHC.SysTools.Process where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session
compiler/GHC/SysTools/Tasks.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- -- Tasks running external programs for SysTools@@ -27,6 +27,7 @@ import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Utils.TmpFs+import GHC.Utils.Constants (isWindowsHost)  import Data.List (tails, isPrefixOf) import System.IO@@ -308,23 +309,19 @@  -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-#if defined(mingw32_HOST_OS)-runMergeObjects logger tmpfs  dflags args =-#else-runMergeObjects logger _tmpfs dflags args =-#endif+runMergeObjects logger tmpfs dflags args =   traceToolCommand logger dflags "merge-objects" $ do     let (p,args0) = pgm_lm dflags         optl_args = map Option (getOpts dflags opt_lm)         args2     = args0 ++ args ++ optl_args     -- N.B. Darwin's ld64 doesn't support response files. Consequently we only     -- use them on Windows where they are truly necessary.-#if defined(mingw32_HOST_OS)-    mb_env <- getGccEnv args2-    runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env-#else-    runSomething logger dflags "Merge objects" p args2-#endif+    if isWindowsHost+      then do+        mb_env <- getGccEnv args2+        runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env+      else do+        runSomething logger dflags "Merge objects" p args2  runLibtool :: Logger -> DynFlags -> [Option] -> IO () runLibtool logger dflags args = traceToolCommand logger dflags "libtool" $ do
compiler/GHC/Tc/Deriv.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} @@ -13,8 +13,6 @@ -- | Handles @deriving@ clauses on @data@ declarations. module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs@@ -61,6 +59,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)@@ -1556,7 +1555,7 @@            cant_derive_err = ppUnless eta_ok  eta_msg            eta_msg = text "cannot eta-reduce the representation type enough" -       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )+       massert (cls_tys `lengthIs` (classArity cls - 1))        if newtype_strat        then            -- Since the user explicitly asked for GeneralizedNewtypeDeriving,@@ -1962,7 +1961,7 @@           at_last_cls_tv_in_kind kind             = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind           at_tcs = classATs cls-          last_cls_tv = ASSERT( notNull cls_tyvars )+          last_cls_tv = assert (notNull cls_tyvars )                         last cls_tyvars            cant_derive_err@@ -2056,8 +2055,8 @@         tyfam_insts <-           -- canDeriveAnyClass should ensure that this code can't be reached           -- unless -XDeriveAnyClass is enabled.-          ASSERT2( isValid (canDeriveAnyClass dflags)-                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )+          assertPpr (isValid (canDeriveAnyClass dflags))+                    (ppr "genDerivStuff: bad derived class" <+> ppr clas) $           mapM (tcATDefault loc mini_subst emptyNameSet)                (classATItems clas)         return ( emptyBag, [] -- No method bindings are needed...
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -3,7 +3,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}@@ -21,8 +21,6 @@    , gen_Traversable_binds    ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -5,7 +5,7 @@  -} -{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}@@ -39,8 +39,6 @@         getPossibleDataCons, tyConInstArgTys     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Tc.Utils.Monad@@ -77,6 +75,7 @@ import GHC.Types.Var import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme import GHC.Data.FastString import GHC.Data.Pair@@ -730,7 +729,7 @@   | isEnumerationTyCon tycon   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)   | otherwise-  = ASSERT(isSingleton data_cons)+  = assert (isSingleton data_cons)     (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)   where     data_cons = tyConDataCons tycon@@ -1137,7 +1136,7 @@      data_con_str con = occNameString (getOccName con) -    read_arg a ty = ASSERT( not (isUnliftedType ty) )+    read_arg a ty = assert (not (isUnliftedType ty)) $                     noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))      -- When reading field labels we might encounter@@ -1210,7 +1209,7 @@      pats_etc data_con       | nullary_con =  -- skip the showParen junk...-         ASSERT(null bs_needed)+         assert (null bs_needed)          ([nlWildPat, con_pat], mk_showString_app op_con_str)       | otherwise   =          ([a_Pat, con_pat],@@ -1945,7 +1944,7 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty   = do let ats = classATs cls            (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)-       atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )+       atf_insts <- assert (all (not . isDataFamilyTyCon) ats) $                     mapM mk_atf_inst ats        return ( listToBag binds               , sigs
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}@@ -54,6 +54,7 @@ import GHC.Types.Var.Set (elemVarSet) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Utils.Misc @@ -61,8 +62,6 @@ import Data.List (zip4, partition) import Data.Maybe (isJust) -#include "GhclibHsVersions.h"- {- ************************************************************************ *                                                                      *@@ -388,7 +387,7 @@         (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons           where gk_ = case gk of                   Gen0 -> Gen0_-                  Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)+                  Gen1 -> assert (tyvars `lengthAtLeast` 1) $                           Gen1_ (last tyvars)                     where tyvars = tyConTyVars tycon @@ -439,7 +438,7 @@      ; let -- `tyvars` = [a,b]            (tyvars, gk_) = case gk of              Gen0 -> (all_tyvars, Gen0_)-             Gen1 -> ASSERT(not $ null all_tyvars)+             Gen1 -> assert (not $ null all_tyvars)                      (init all_tyvars, Gen1_ $ last all_tyvars)              where all_tyvars = tyConTyVars tycon @@ -618,7 +617,7 @@         -- The Bool is True if this constructor has labelled fields         prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type         prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])-                                  [ ASSERT(null fl || lengthExceeds fl j)+                                  [ assert (null fl || lengthExceeds fl j) $                                     arg t sb' ib' (if null fl                                                       then Nothing                                                       else Just (fl !! j))
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE MultiWayIf #-}  -- | Functions for inferring (and simplifying) the context for derived instances.@@ -14,8 +14,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Data.Bag@@ -26,6 +24,7 @@ import GHC.Tc.Utils.Instantiate import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Pair import GHC.Builtin.Names import GHC.Tc.Deriv.Utils@@ -113,12 +112,12 @@              -- Constraints arising from superclasses              -- See Note [Superclasses of derived instance]              cls_tvs  = classTyVars main_cls-             sc_constraints = ASSERT2( equalLength cls_tvs inst_tys-                                     , ppr main_cls <+> ppr inst_tys )+             sc_constraints = assertPpr (equalLength cls_tvs inst_tys)+                                        (ppr main_cls <+> ppr inst_tys)                               [ mkThetaOrigin (mkDerivOrigin wildcard)                                               TypeLevel [] [] [] $                                 substTheta cls_subst (classSCTheta main_cls) ]-             cls_subst = ASSERT( equalLength cls_tvs inst_tys )+             cls_subst = assert (equalLength cls_tvs inst_tys) $                          zipTvSubst cls_tvs inst_tys         ; (inferred_constraints, tvs', inst_tys') <- infer_constraints@@ -269,7 +268,7 @@                  substTheta tc_subst (tyConStupidTheta rep_tc) ]            tc_subst = -- See the comment with all_rep_tc_args for an                       -- explanation of this assertion-                      ASSERT( equalLength rep_tc_tvs all_rep_tc_args )+                      assert (equalLength rep_tc_tvs all_rep_tc_args) $                       zipTvSubst rep_tc_tvs all_rep_tc_args             -- Extra Data constraints@@ -308,9 +307,9 @@              -- Generic1 needs Functor              -- See Note [Getting base classes]           |  is_generic1-           -> ASSERT( rep_tc_tvs `lengthExceeds` 0 )+           -> assert (rep_tc_tvs `lengthExceeds` 0) $               -- Generic1 has a single kind variable-              ASSERT( cls_tys `lengthIs` 1 )+              assert (cls_tys `lengthIs` 1) $               do { functorClass <- lift $ tcLookupClass functorClassName                  ; pure $ con_arg_constraints                         $ get_gen1_constraints functorClass }@@ -319,9 +318,9 @@           |  otherwise            -> -- See the comment with all_rep_tc_args for an explanation of               -- this assertion-              ASSERT2( equalLength rep_tc_tvs all_rep_tc_args-                     , ppr main_cls <+> ppr rep_tc-                       $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )+              assertPpr (equalLength rep_tc_tvs all_rep_tc_args)+                        ( ppr main_cls <+> ppr rep_tc+                          $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args) $                 do { let (arg_constraints, tvs', inst_tys')                            = con_arg_constraints get_std_constrained_tys                    ; lift $ traceTc "inferConstraintsStock" $ vcat
compiler/GHC/Tc/Errors.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,8 +12,6 @@        solverDepthErrorTcS   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Tc.Types@@ -25,7 +23,7 @@ import GHC.Tc.Utils.Env( tcInitTidyEnv ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Origin-import GHC.Rename.Unbound ( unknownNameSuggestions )+import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCo.Rep@@ -42,7 +40,8 @@ import GHC.Tc.Types.EvTerm import GHC.Hs.Binds ( PatSynBind(..) ) import GHC.Types.Name-import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual )+import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual+                             , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc ) import GHC.Builtin.Names ( typeableClassName ) import GHC.Types.Id import GHC.Types.Var@@ -59,6 +58,7 @@ import GHC.Data.FastString import GHC.Utils.Outputable as O import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Driver.Session import GHC.Driver.Ppr@@ -66,6 +66,7 @@ import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.FV ( fvVarList, unionFV )+import qualified GHC.Data.Strict as Strict  import Control.Monad    ( unless, when, foldM, forM_ ) import Data.Foldable    ( toList )@@ -555,7 +556,7 @@          -- says to suppress        ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }        ; (_, leftovers) <- tryReporters ctxt2 report2 cts1-       ; MASSERT2( null leftovers, ppr leftovers )+       ; massertPpr (null leftovers) (ppr leftovers)              -- All the Derived ones have been filtered out of simples             -- by the constraint solver. This is ok; we don't want@@ -1033,7 +1034,7 @@ mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs)   = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)        ; mkTcRnMessage rea-           (RealSrcSpan (tcl_loc tcl_env) Nothing)+           (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)            (vcat important)            context            (vcat $ relevant_bindings ++ valid_subs)@@ -1045,7 +1046,7 @@                 -> Report                 -> TcM (MsgEnvelope TcRnMessage) mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs)-  = mkTcRnMessage rea (RealSrcSpan (tcl_loc tcl_env) Nothing)+  = mkTcRnMessage rea (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)     (vcat important)     O.empty     (vcat $ relevant_bindings ++ valid_subs)@@ -1198,7 +1199,7 @@        ; hpt <- getHpt        ; let err = important out_of_scope_msg `mappend`                    (mk_relevant_bindings $-                     unknownNameSuggestions dflags hpt curr_mod rdr_env+                     unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env                        (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ))         ; maybeAddDeferredBindings ctxt hole err@@ -1629,8 +1630,8 @@   -- See Note [Error messages for untouchables]   | (implic:_) <- cec_encl ctxt   -- Get the innermost context   , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic-  = ASSERT2( not (isTouchableMetaTyVar lvl tv1)-           , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]+  = assertPpr (not (isTouchableMetaTyVar lvl tv1))+              (ppr tv1 $$ ppr lvl) $  -- See Note [Error messages for untouchables]     let msg         = misMatchMsg ctxt ct ty1 ty2         tclvl_extra = important $              nest 2 $@@ -1800,7 +1801,7 @@  extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc extraTyVarInfo ctxt tv-  = ASSERT2( isTyVar tv, ppr tv )+  = assertPpr (isTyVar tv) (ppr tv) $     case tcTyVarDetails tv of           SkolemTv {}   -> pprSkols ctxt [tv]           RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"@@ -2344,7 +2345,7 @@  mkDictErr :: ReportErrCtxt -> [Ct] -> TcM Report mkDictErr ctxt cts-  = ASSERT( not (null cts) )+  = assert (not (null cts)) $     do { inst_envs <- tcGetInstEnvs        ; let min_cts = elim_superclasses cts              lookups = map (lookup_cls_inst inst_envs) min_cts@@ -2385,7 +2386,8 @@   | null matches  -- No matches but perhaps several unifiers   = do { (_, binds_msg, ct) <- relevantBindings True ctxt ct        ; candidate_insts <- get_candidate_instances-       ; return (cannot_resolve_msg ct candidate_insts binds_msg) }+       ; field_suggestions <- record_field_suggestions+       ; return (cannot_resolve_msg ct candidate_insts binds_msg field_suggestions) }    | null unsafe_overlapped   -- Some matches => overlap errors   = return overlap_msg@@ -2422,8 +2424,30 @@         in different_names && same_occ_names       | otherwise = False -    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc-    cannot_resolve_msg ct candidate_insts binds_msg+    -- See Note [Out-of-scope fields with -XOverloadedRecordDot]+    record_field_suggestions :: TcM SDoc+    record_field_suggestions = flip (maybe $ return empty) record_field $ \name ->+       do { glb_env <- getGlobalRdrEnv+          ; lcl_env <- getLocalRdrEnv+          ; if occ_name_in_scope glb_env lcl_env name+              then return empty+              else do { dflags   <- getDynFlags+                      ; imp_info <- getImports+                      ; curr_mod <- getModule+                      ; hpt      <- getHpt+                      ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod+                          glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } }++    occ_name_in_scope glb_env lcl_env occ_name = not $+      null (lookupGlobalRdrEnv glb_env occ_name) &&+      isNothing (lookupLocalRdrOcc lcl_env occ_name)++    record_field = case orig of+      HasFieldOrigin name -> Just (mkVarOccFS name)+      _                   -> Nothing++    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc -> SDoc+    cannot_resolve_msg ct candidate_insts binds_msg field_suggestions       = vcat [ no_inst_msg              , nest 2 extra_note              , vcat (pp_givens useful_givens)@@ -2438,8 +2462,9 @@                            ++ drv_fixes)              , ppWhen (not (null candidate_insts))                (hang (text "There are instances for similar types:")-                   2 (vcat (map ppr candidate_insts))) ]+                   2 (vcat (map ppr candidate_insts)))                    -- See Note [Report candidate instances]+             , field_suggestions ]       where         orig = ctOrigin ct         -- See Note [Highlighting ambiguous type variables]@@ -2518,7 +2543,7 @@      -- Normal overlap error     overlap_msg-      = ASSERT( not (null matches) )+      = assert (not (null matches)) $         vcat [  addArising orig (text "Overlapping instances for"                                 <+> pprType (mkClassPred clas tys)) @@ -2571,7 +2596,7 @@     -- Overlap error because of Safe Haskell (first     -- match should be the most specific match)     safe_haskell_msg-     = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )+     = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $        vcat [ addArising orig (text "Unsafe overlapping instances for"                        <+> pprType (mkClassPred clas tys))             , sep [text "The matching instance is:",@@ -2710,6 +2735,33 @@          ... Possible fix: add (Show a) to the context of          the signature for pattern synonym `Pat' ... +Note [Out-of-scope fields with -XOverloadedRecordDot]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With -XOverloadedRecordDot, when a field isn't in scope, the error that appears+is produces here, and it says+    No instance for (GHC.Record.HasField "<fieldname>" ...).++Additionally, though, we want to suggest similar field names that are in scope+or could be in scope with different import lists.++However, we can still get an error about a missing HasField instance when a+field is in scope (if the types are wrong), and so it's important that we don't+suggest similar names here if the record field is in scope, either qualified or+unqualified, since qualification doesn't matter for -XOverloadedRecordDot.++Example:++    import Data.Monoid (Alt(..))++    foo = undefined.getAll++results in++     No instance for (GHC.Records.HasField "getAll" r0 a0)+        arising from selecting the field ‘getAll’+      Perhaps you meant ‘getAlt’ (imported from Data.Monoid)+      Perhaps you want to add ‘getAll’ to the import list+      in the import of ‘Data.Monoid’ -}  show_fixes :: [SDoc] -> SDoc
compiler/GHC/Tc/Errors/Hole.hs view
@@ -1,10 +1,30 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module GHC.Tc.Errors.Hole    ( findValidHoleFits+   , tcCheckHoleFit+   , withoutUnification+   , tcSubsumes+   , isFlexiTyVar+   , tcFilterHoleFits+   , getLocalBindings+   , pprHoleFit+   , addHoleFitDocs+   , getHoleFitSortingAlg+   , getHoleFitDispConfig+   , HoleFitDispConfig (..)+   , HoleFitSortingAlg (..)+   , relevantCts+   , zonkSubs +   , sortHoleFitsByGraph+   , sortHoleFitsBySize++    -- Re-exported from GHC.Tc.Errors.Hole.FitTypes    , HoleFitPlugin (..), HoleFitPluginR (..)    )@@ -393,37 +413,37 @@                     , showMatches = sMatc } }  -- Which sorting algorithm to use-data SortingAlg = NoSorting      -- Do not sort the fits at all-                | BySize         -- Sort them by the size of the match-                | BySubsumption  -- Sort by full subsumption+data HoleFitSortingAlg = HFSNoSorting      -- Do not sort the fits at all+                       | HFSBySize         -- Sort them by the size of the match+                       | HFSBySubsumption  -- Sort by full subsumption                 deriving (Eq, Ord) -getSortingAlg :: TcM SortingAlg-getSortingAlg =+getHoleFitSortingAlg :: TcM HoleFitSortingAlg+getHoleFitSortingAlg =     do { shouldSort <- goptM Opt_SortValidHoleFits        ; subsumSort <- goptM Opt_SortBySubsumHoleFits        ; sizeSort <- goptM Opt_SortBySizeHoleFits        -- We default to sizeSort unless it has been explicitly turned off        -- or subsumption sorting has been turned on.        ; return $ if not shouldSort-                    then NoSorting+                    then HFSNoSorting                     else if subsumSort-                         then BySubsumption+                         then HFSBySubsumption                          else if sizeSort-                              then BySize-                              else NoSorting }+                              then HFSBySize+                              else HFSNoSorting }  -- If enabled, we go through the fits and add any associated documentation, -- by looking it up in the module or the environment (for local fits)-addDocs :: [HoleFit] -> TcM [HoleFit]-addDocs fits =+addHoleFitDocs :: [HoleFit] -> TcM [HoleFit]+addHoleFitDocs fits =   do { showDocs <- goptM Opt_ShowDocsOfHoleFits      ; if showDocs        then do { (_, DeclDocMap lclDocs, _) <- getGblEnv >>= extractDocs                ; mapM (upd lclDocs) fits }        else return fits }   where-   msg = text "GHC.Tc.Errors.Hole addDocs"+   msg = text "GHC.Tc.Errors.Hole addHoleFitDocs"    lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })      = Map.lookup name dmap    upd lclDocs fit@(HoleFit {hfCand = cand}) =@@ -530,12 +550,13 @@      ; lclBinds <- getLocalBindings tidy_env ct_loc      ; maxVSubs <- maxValidHoleFits <$> getDynFlags      ; hfdc <- getHoleFitDispConfig-     ; sortingAlg <- getSortingAlg+     ; sortingAlg <- getHoleFitSortingAlg      ; dflags <- getDynFlags      ; hfPlugs <- tcg_hf_plugins <$> getGblEnv-     ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs+     ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs            refLevel = refLevelHoleFits dflags-           hole = TypedHole { th_relevant_cts = listToBag relevantCts+           hole = TypedHole { th_relevant_cts =+                                listToBag (relevantCts hole_ty simples)                             , th_implics      = implics                             , th_hole         = Just h }            (candidatePlugins, fitPlugins) =@@ -563,7 +584,7 @@      ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins      ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs            vDiscards = pVDisc || searchDiscards-     ; subs_with_docs <- addDocs limited_subs+     ; subs_with_docs <- addHoleFitDocs limited_subs      ; let vMsg = ppUnless (null subs_with_docs) $                     hang (text "Valid hole fits include") 2 $                       vcat (map (pprHoleFit hfdc) subs_with_docs)@@ -578,8 +599,8 @@             -- to allow.             ; ref_tys <- mapM mkRefTy refLvls             ; traceTc "ref_tys are" $ ppr ref_tys-            ; let findRLimit = if sortingAlg > NoSorting then Nothing-                                                         else maxRSubs+            ; let findRLimit = if sortingAlg > HFSNoSorting then Nothing+                                                            else maxRSubs             ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole)                               cands) ref_tys             ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs@@ -596,7 +617,7 @@             ; let (pRDisc, exact_last_rfits) =                     possiblyDiscard maxRSubs $ plugin_handled_rsubs                   rDiscards = pRDisc || any fst refDs-            ; rsubs_with_docs <- addDocs exact_last_rfits+            ; rsubs_with_docs <- addHoleFitDocs exact_last_rfits             ; return (tidy_env,                 ppUnless (null rsubs_with_docs) $                   hang (text "Valid refinement hole fits include") 2 $@@ -606,10 +627,7 @@      ; traceTc "findingValidHoleFitsFor }" empty      ; return (tidy_env, vMsg $$ refMsg) }   where-    -- We extract the type, the TcLevel and the types free variables-    -- from the constraint.-    hole_fvs :: FV-    hole_fvs = tyCoFVsOfType hole_ty+    -- We extract the TcLevel from the constraint.     hole_lvl = ctLocLevel ct_loc      -- BuiltInSyntax names like (:) and []@@ -629,58 +647,37 @@             setLvl = flip setMetaTyVarTcLevel hole_lvl             wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty -    sortFits :: SortingAlg    -- How we should sort the hole fits+    sortFits :: HoleFitSortingAlg    -- How we should sort the hole fits              -> [HoleFit]     -- The subs to sort              -> TcM [HoleFit]-    sortFits NoSorting subs = return subs-    sortFits BySize subs-        = (++) <$> sortBySize (sort lclFits)-               <*> sortBySize (sort gblFits)+    sortFits HFSNoSorting subs = return subs+    sortFits HFSBySize subs+        = (++) <$> sortHoleFitsBySize (sort lclFits)+               <*> sortHoleFitsBySize (sort gblFits)         where (lclFits, gblFits) = span hfIsLcl subs-     -- To sort by subsumption, we invoke the sortByGraph function, which     -- builds the subsumption graph for the fits and then sorts them using a     -- graph sort.  Since we want locals to come first anyway, we can sort     -- them separately. The substitutions are already checked in local then     -- global order, so we can get away with using span here.     -- We use (<*>) to expose the parallelism, in case it becomes useful later.-    sortFits BySubsumption subs-        = (++) <$> sortByGraph (sort lclFits)-               <*> sortByGraph (sort gblFits)+    sortFits HFSBySubsumption subs+        = (++) <$> sortHoleFitsByGraph (sort lclFits)+               <*> sortHoleFitsByGraph (sort gblFits)         where (lclFits, gblFits) = span hfIsLcl subs -    -- See Note [Relevant constraints]-    relevantCts :: [Ct]-    relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then []-                  else filter isRelevant simples-      where ctFreeVarSet :: Ct -> VarSet-            ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred-            hole_fv_set = fvVarSet hole_fvs-            anyFVMentioned :: Ct -> Bool-            anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set-            -- We filter out those constraints that have no variables (since-            -- they won't be solved by finding a type for the type variable-            -- representing the hole) and also other holes, since we're not-            -- trying to find hole fits for many holes at once.-            isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))-                            && anyFVMentioned ct+    subsDiscardMsg :: SDoc+    subsDiscardMsg =+        text "(Some hole fits suppressed;" <+>+        text "use -fmax-valid-hole-fits=N" <+>+        text "or -fno-max-valid-hole-fits)" -    -- We zonk the hole fits so that the output aligns with the rest-    -- of the typed hole error message output.-    zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])-    zonkSubs = zonkSubs' []-      where zonkSubs' zs env [] = return (env, reverse zs)-            zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf-                                           ; zonkSubs' (z:zs) env' hfs }+    refSubsDiscardMsg :: SDoc+    refSubsDiscardMsg =+        text "(Some refinement hole fits suppressed;" <+>+        text "use -fmax-refinement-hole-fits=N" <+>+        text "or -fno-max-refinement-hole-fits)" -            zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)-            zonkSub env hf@RawHoleFit{} = return (env, hf)-            zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}-              = do { (env, ty') <- zonkTidyTcType env ty-                   ; (env, m') <- zonkTidyTcTypes env m-                   ; (env, wrp') <- zonkTidyTcTypes env wrp-                   ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'}-                   ; return (env, zFit ) }      -- Based on the flags, we might possibly discard some or all the     -- fits we've found.@@ -688,42 +685,74 @@     possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits)     possiblyDiscard Nothing fits = (False, fits) -    -- Sort by size uses as a measure for relevance the sizes of the-    -- different types needed to instantiate the fit to the type of the hole.-    -- This is much quicker than sorting by subsumption, and gives reasonable-    -- results in most cases.-    sortBySize :: [HoleFit] -> TcM [HoleFit]-    sortBySize = return . sortOn sizeOfFit-      where sizeOfFit :: HoleFit -> TypeSize-            sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap -    -- Based on a suggestion by phadej on #ghc, we can sort the found fits-    -- by constructing a subsumption graph, and then do a topological sort of-    -- the graph. This makes the most specific types appear first, which are-    -- probably those most relevant. This takes a lot of work (but results in-    -- much more useful output), and can be disabled by-    -- '-fno-sort-valid-hole-fits'.-    sortByGraph :: [HoleFit] -> TcM [HoleFit]-    sortByGraph fits = go [] fits-      where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool-            tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty)-              where fvs = tyCoFVsOfTypes [ht,ty]-            go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]-            go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar-                             ; return $ uncurry (++)-                                         $ partition hfIsLcl topSorted }-              where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)-                    (graph, fromV, _) = graphFromEdges $ map toV sofar-                    topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph-            go sofar (hf:hfs) =-              do { adjs <--                     filterM (tcSubsumesWCloning (hfType hf) . hfType) fits-                 ; go ((hf, adjs):sofar) hfs }- -- We don't (as of yet) handle holes in types, only in expressions. findValidHoleFits env _ _ _ = return (env, empty) +-- See Note [Relevant constraints]+relevantCts :: Type -> [Ct] -> [Ct]+relevantCts hole_ty simples = if isEmptyVarSet (fvVarSet hole_fvs) then []+                              else filter isRelevant simples+  where ctFreeVarSet :: Ct -> VarSet+        ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred+        hole_fvs = tyCoFVsOfType hole_ty+        hole_fv_set = fvVarSet hole_fvs+        anyFVMentioned :: Ct -> Bool+        anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set+        -- We filter out those constraints that have no variables (since+        -- they won't be solved by finding a type for the type variable+        -- representing the hole) and also other holes, since we're not+        -- trying to find hole fits for many holes at once.+        isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))+                        && anyFVMentioned ct +-- We zonk the hole fits so that the output aligns with the rest+-- of the typed hole error message output.+zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])+zonkSubs = zonkSubs' []+  where zonkSubs' zs env [] = return (env, reverse zs)+        zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf+                                        ; zonkSubs' (z:zs) env' hfs }++        zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)+        zonkSub env hf@RawHoleFit{} = return (env, hf)+        zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}+            = do { (env, ty') <- zonkTidyTcType env ty+                ; (env, m') <- zonkTidyTcTypes env m+                ; (env, wrp') <- zonkTidyTcTypes env wrp+                ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'}+                ; return (env, zFit ) }++-- | Sort by size uses as a measure for relevance the sizes of the different+-- types needed to instantiate the fit to the type of the hole.+-- This is much quicker than sorting by subsumption, and gives reasonable+-- results in most cases.+sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit]+sortHoleFitsBySize = return . sortOn sizeOfFit+  where sizeOfFit :: HoleFit -> TypeSize+        sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap++-- Based on a suggestion by phadej on #ghc, we can sort the found fits+-- by constructing a subsumption graph, and then do a topological sort of+-- the graph. This makes the most specific types appear first, which are+-- probably those most relevant. This takes a lot of work (but results in+-- much more useful output), and can be disabled by+-- '-fno-sort-valid-hole-fits'.+sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]+sortHoleFitsByGraph fits = go [] fits+  where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool+        tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty)+          where fvs = tyCoFVsOfTypes [ht,ty]+        go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]+        go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar+                         ; return $ uncurry (++) $ partition hfIsLcl topSorted }+          where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)+                (graph, fromV, _) = graphFromEdges $ map toV sofar+                topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph+        go sofar (hf:hfs) =+          do { adjs <- filterM (tcSubsumesWCloning (hfType hf) . hfType) fits+             ; go ((hf, adjs):sofar) hfs }+ -- | tcFilterHoleFits filters the candidates by whether, given the implications -- and the relevant constraints, they can be made to match the type by -- running the type checker. Stops after finding limit matches.@@ -878,17 +907,6 @@      where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty            hole = typed_hole { th_hole = Nothing } -subsDiscardMsg :: SDoc-subsDiscardMsg =-    text "(Some hole fits suppressed;" <+>-    text "use -fmax-valid-hole-fits=N" <+>-    text "or -fno-max-valid-hole-fits)"--refSubsDiscardMsg :: SDoc-refSubsDiscardMsg =-    text "(Some refinement hole fits suppressed;" <+>-    text "use -fmax-refinement-hole-fits=N" <+>-    text "or -fno-max-refinement-hole-fits)"   -- | Checks whether a MetaTyVar is flexible or not.
compiler/GHC/Tc/Errors/Hole.hs-boot view
@@ -4,10 +4,40 @@ -- + which calls 'GHC.Tc.Solver.simpl_top' module GHC.Tc.Errors.Hole where +import GHC.Types.Var ( Id ) import GHC.Tc.Types  ( TcM )-import GHC.Tc.Types.Constraint ( Ct, Hole, Implication )+import GHC.Tc.Types.Constraint ( Ct, CtLoc, Hole, Implication ) import GHC.Utils.Outputable ( SDoc ) import GHC.Types.Var.Env ( TidyEnv )+import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate )+import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, Type, TcTyVar )+import GHC.Tc.Types.Evidence ( HsWrapper )+import GHC.Utils.FV ( FV )+import Data.Bool ( Bool )+import Data.Maybe ( Maybe )+import Data.Int ( Int )  findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole                   -> TcM (TidyEnv, SDoc)++tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType+               -> TcM (Bool, HsWrapper)++withoutUnification :: FV -> TcM a -> TcM a+tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool+tcFilterHoleFits :: Maybe Int -> TypedHole -> (TcType, [TcTyVar])+                 -> [HoleFitCandidate] -> TcM (Bool, [HoleFit])+getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id]+addHoleFitDocs :: [HoleFit] -> TcM [HoleFit]++data HoleFitDispConfig+data HoleFitSortingAlg++pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc+getHoleFitSortingAlg :: TcM HoleFitSortingAlg+getHoleFitDispConfig :: TcM HoleFitDispConfig++relevantCts :: Type -> [Ct] -> [Ct]+zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])+sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit]+sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]
compiler/GHC/Tc/Gen/App.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE GADTs               #-}@@ -54,8 +54,6 @@ import Control.Monad import Data.Function -#include "GhclibHsVersions.h"- import GHC.Prelude  {- *********************************************************************@@ -140,7 +138,7 @@   = addExprCtxt rn_expr $     setSrcSpanA loc     $     do { do_ql <- wantQuickLook rn_fun-       ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args Nothing+       ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args        ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args        ; _tc_args <- tcValArgs do_ql inst_args        ; return app_res_sigma }@@ -165,7 +163,7 @@      | {-# PRAGMA #-} app  -- HsPragE: pragmas  head ::= f             -- HsVar:    variables-      |  fld           -- HsRecFld: record field selectors+      |  fld           -- HsRecSel: record field selectors       |  (expr :: ty)  -- ExprWithTySig: expr with user type sig       |  lit           -- HsOverLit: overloaded literals       |  other_expr    -- Other expressions@@ -228,7 +226,7 @@ 2. Use tcInferAppHead to infer the type of the function,      as an (uninstantiated) TcSigmaType    There are special cases for-     HsVar, HsRecFld, and ExprWithTySig+     HsVar, HsRecSel, and ExprWithTySig    Otherwise, delegate back to tcExpr, which      infers an (instantiated) TcRhoType @@ -313,7 +311,6 @@ tcApp rn_expr exp_res_ty   | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr   = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args-                                    (checkingExpType_maybe exp_res_ty)         -- Instantiate        ; do_ql <- wantQuickLook rn_fun@@ -854,7 +851,7 @@               -> TcM (Delta, EValArg 'TcpInst) quickLookArg1 guarded delta larg@(L _ arg) arg_ty   = do { let (fun@(rn_fun, fun_ctxt), rn_args) = splitHsApps arg-       ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args (Just arg_ty)+       ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args        ; traceTc "quickLookArg 1" $          vcat [ text "arg:" <+> ppr arg               , text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty@@ -991,7 +988,7 @@      ----------------     go_kappa bvs kappa ty2-      = ASSERT2( isMetaTyVar kappa, ppr kappa )+      = assertPpr (isMetaTyVar kappa) (ppr kappa) $         do { info <- readMetaTyVar kappa            ; case info of                Indirect ty1 -> go bvs ty1 ty2
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -145,9 +145,9 @@         ; return (L loc cmd') }  tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTc)-tc_cmd env (HsCmdPar x cmd) res_ty+tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty   = do  { cmd' <- tcCmd env cmd res_ty-        ; return (HsCmdPar x cmd') }+        ; return (HsCmdPar x lpar cmd' rpar) }  tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty   = do  { (binds', body') <- tcLocalBinds binds         $
compiler/GHC/Tc/Gen/Bind.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -78,8 +78,6 @@  import Control.Monad import Data.Foldable (find)--#include "GhclibHsVersions.h"  {- ************************************************************************
compiler/GHC/Tc/Gen/Export.hs view
@@ -10,6 +10,7 @@ import GHC.Hs import GHC.Types.FieldLabel import GHC.Builtin.Names+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType@@ -394,8 +395,7 @@              addUsedKids (ieWrappedName rdr) gres              when (null gres) $                   if isTyConName name-                  then addDiagnostic (WarningWithFlag Opt_WarnDodgyExports)-                                     (dodgyExportWarn name)+                  then addTcRnDiagnostic (TcRnDodgyExports name)                   else -- This occurs when you export T(..), but                        -- only import T abstractly, or T is a synonym.                        addErr (exportItemErr ie)@@ -758,10 +758,6 @@           quotes (text "module" <+> ppr mod),           text "is missing an export list"] --dodgyExportWarn :: Name -> SDoc-dodgyExportWarn item-  = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)  exportErrCtxt :: Outputable o => String -> o -> SDoc exportErrCtxt herald exp =
compiler/GHC/Tc/Gen/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -23,11 +23,8 @@          tcPolyExpr, tcExpr,          tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,          tcCheckId,-         addAmbiguousNameErr,          getFixedTyVars ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )@@ -77,6 +74,7 @@ import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad import GHC.Core.Class(classTyCon) import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )@@ -185,7 +183,7 @@ --   - HsApp         value applications --   - HsAppType     type applications --   - ExprWithTySig (e :: type)---   - HsRecFld      overloaded record fields+--   - HsRecSel      overloaded record fields --   - HsExpanded    renamer expansions --   - HsOpApp       operator applications --   - HsOverLit     overloaded literals@@ -198,7 +196,7 @@ tcExpr e@(OpApp {})              res_ty = tcApp e res_ty tcExpr e@(HsAppType {})          res_ty = tcApp e res_ty tcExpr e@(ExprWithTySig {})      res_ty = tcApp e res_ty-tcExpr e@(HsRecFld {})           res_ty = tcApp e res_ty+tcExpr e@(HsRecSel {})           res_ty = tcApp e res_ty tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty  tcExpr e@(HsOverLit _ lit) res_ty@@ -223,9 +221,9 @@   = do { let lit_ty = hsLitType lit        ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } -tcExpr (HsPar x expr) res_ty+tcExpr (HsPar x lpar expr rpar) res_ty   = do { expr' <- tcMonoExprNC expr res_ty-       ; return (HsPar x expr') }+       ; return (HsPar x lpar expr' rpar) }  tcExpr (HsPragE x prag expr) res_ty   = do { expr' <- tcMonoExpr expr res_ty@@ -329,10 +327,9 @@        ; let expr'       = ExplicitTuple x tup_args1 boxity              missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] -             -- See Note [Linear fields generalization] in GHC.Tc.Gen.App-             act_res_ty-                 = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)-                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+             -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head+             -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+             act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)         ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) @@ -643,7 +640,7 @@ -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty-  = ASSERT( notNull rbnds )+  = assert (notNull rbnds) $     do  { -- STEP -2: typecheck the record_expr, the record to be updated           (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr             -- Record update drops some of the content of the record (namely the@@ -663,7 +660,7 @@         -- STEP -1  See Note [Disambiguating record fields] in GHC.Tc.Gen.Head         -- After this we know that rbinds is unambiguous         ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty-        ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds+        ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds               upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds               sel_ids      = map selectorAmbiguousFieldOcc upd_flds         -- STEP 0@@ -680,7 +677,7 @@         -- See note [Mixed Record Selectors]         ; let (data_sels, pat_syn_sels) =                 partition isDataConRecordSelector sel_ids-        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )+        ; massert (all isPatSynRecordSelector pat_syn_sels)         ; checkTc ( null data_sels || null pat_syn_sels )                   ( mixedSelectors data_sels pat_syn_sels ) @@ -714,7 +711,7 @@         ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)          -- Take apart a representative constructor-        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons+        ; let con1 = assert (not (null relevant_cons) ) head relevant_cons               (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)                  = conLikeFullSig con1               con1_arg_tys = map scaledThing scaled_con1_arg_tys@@ -870,7 +867,6 @@ ************************************************************************ -} -tcExpr (HsConLikeOut {})   ty = pprPanic "tcExpr:HsConLikeOut" (ppr ty) tcExpr (HsOverLabel {})    ty = pprPanic "tcExpr:HsOverLabel"  (ppr ty) tcExpr (SectionL {})       ty = pprPanic "tcExpr:SectionL"    (ppr ty) tcExpr (SectionR {})       ty = pprPanic "tcExpr:SectionR"    (ppr ty)@@ -942,7 +938,7 @@ ---------------- tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc] tcTupArgs args tys-  = do MASSERT( equalLength args tys )+  = do massert (equalLength args tys)        checkTupSize (length args)        mapM go (args `zip` tys)   where@@ -977,7 +973,7 @@               -> ([TcSigmaType] -> [Mult] -> TcM a)               -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside-  = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) [] Nothing+  = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) []              -- Ugh!! But all this code is scheduled for demolition anyway        ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)        ; (result, expr_wrap, arg_wraps, res_wrap)@@ -1038,11 +1034,11 @@                           -- another nested arrow is too much for now,                          -- but I bet we'll never need this-                     ; MASSERT2( case arg_shape of+                     ; massertPpr (case arg_shape of                                    SynFun {} -> False;-                                   _         -> True-                               , text "Too many nested arrows in SyntaxOpType" $$-                                 pprCtOrigin orig )+                                   _         -> True)+                                  (text "Too many nested arrows in SyntaxOpType" $$+                                   pprCtOrigin orig)                       ; let arg_mult = scaledMult arg_ty                      ; tcSynArgA orig arg_tc_ty [] arg_shape $@@ -1187,7 +1183,7 @@ -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType                  -> [LHsRecUpdField GhcRn] -> ExpRhoType-                 -> TcM [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+                 -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] disambiguateRecordBinds record_expr record_rho rbnds res_ty     -- Are all the fields unambiguous?   = case mapM isUnambiguous rbnds of@@ -1206,7 +1202,7 @@   where     -- Extract the selector name of a field update if it is unambiguous     isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)-    isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of+    isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of                         Unambiguous sel_name _ -> Just (x, sel_name)                         Ambiguous{}            -> Nothing @@ -1252,7 +1248,7 @@     -- where T does not have field x.     pickParent :: RecSelParent                -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])-               -> TcM (LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+               -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))     pickParent p (upd, xs)       = case lookup p xs of                       -- Phew! The parent is valid for this field.@@ -1261,7 +1257,7 @@                       -- unambiguous ones shouldn't be recorded again                       -- (giving duplicate deprecation warnings).           Just gre -> do { unless (null (tail xs)) $ do-                             let L loc _ = hsRecFieldLbl (unLoc upd)+                             let L loc _ = hfbLHS (unLoc upd)                              setSrcSpan loc $ addUsedGRE True gre                          ; lookupSelector (upd, greMangledName gre) }                       -- The field doesn't belong to this parent, so report@@ -1273,19 +1269,19 @@     -- Given a (field update, selector name) pair, look up the     -- selector to give a field update with an unambiguous Id     lookupSelector :: (LHsRecUpdField GhcRn, Name)-                 -> TcM (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+                 -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))     lookupSelector (L l upd, n)       = do { i <- tcLookupId n-           ; let L loc af = hsRecFieldLbl upd+           ; let L loc af = hfbLHS upd                  lbl      = rdrNameAmbiguousFieldOcc af-           -- ; return $ L l upd { hsRecFieldLbl+           -- ; return $ L l upd { hfbLHS            --                = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) }-           ; return $ L l HsRecField-               { hsRecFieldAnn = hsRecFieldAnn upd-               , hsRecFieldLbl+           ; return $ L l HsFieldBind+               { hfbAnn = hfbAnn upd+               , hfbLHS                        = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl))-               , hsRecFieldArg = hsRecFieldArg upd-               , hsRecPun = hsRecPun upd+               , hfbRHS = hfbRHS upd+               , hfbPun = hfbPun upd                }            } @@ -1335,24 +1331,24 @@      do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)             -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))-    do_bind (L l fld@(HsRecField { hsRecFieldLbl = f-                                 , hsRecFieldArg = rhs }))+    do_bind (L l fld@(HsFieldBind { hfbLHS = f+                                 , hfbRHS = rhs }))        = do { mb <- tcRecordField con_like flds_w_tys f rhs            ; case mb of                Nothing         -> return Nothing-               -- Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'-               --                                            , hsRecFieldArg = rhs' }))) }-               Just (f', rhs') -> return (Just (L l (HsRecField-                                                     { hsRecFieldAnn = hsRecFieldAnn fld-                                                     , hsRecFieldLbl = f'-                                                     , hsRecFieldArg = rhs'-                                                     , hsRecPun = hsRecPun fld}))) }+               -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f'+               --                                            , hfbRHS = rhs' }))) }+               Just (f', rhs') -> return (Just (L l (HsFieldBind+                                                     { hfbAnn = hfbAnn fld+                                                     , hfbLHS = f'+                                                     , hfbRHS = rhs'+                                                     , hfbPun = hfbPun fld}))) }  tcRecordUpd         :: ConLike         -> [TcType]     -- Expected type for each field-        -> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+        -> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]         -> TcM [LHsRecUpdField GhcTc]  tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds@@ -1360,10 +1356,10 @@     fields = map flSelector $ conLikeFieldLabels con_like     flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys -    do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)+    do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)             -> TcM (Maybe (LHsRecUpdField GhcTc))-    do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af-                                 , hsRecFieldArg = rhs }))+    do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af+                                 , hfbRHS = rhs }))       = do { let lbl = rdrNameAmbiguousFieldOcc af                  sel_id = selectorAmbiguousFieldOcc af                  f = L loc (FieldOcc (idName sel_id) (L (noAnnSrcSpan loc) lbl))@@ -1372,11 +1368,11 @@                Nothing         -> return Nothing                Just (f', rhs') ->                  return (Just-                         (L l (fld { hsRecFieldLbl+                         (L l (fld { hfbLHS                                       = L loc (Unambiguous-                                               (extFieldOcc (unLoc f'))+                                               (foExt (unLoc f'))                                                (L (noAnnSrcSpan loc) lbl))-                                   , hsRecFieldArg = rhs' }))) }+                                   , hfbRHS = rhs' }))) }  tcRecordField :: ConLike -> Assoc Name Type               -> LFieldOcc GhcRn -> LHsExpr GhcRn@@ -1474,7 +1470,7 @@        2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])  badFieldsUpd-  :: [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+  :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]                -- Field names that don't belong to a single datacon   -> [ConLike] -- Data cons of the type which the first field name belongs to   -> SDoc@@ -1503,14 +1499,14 @@             -- are redundant and can be dropped.             map (fst . head) $ groupBy ((==) `on` snd) growingSets -    aMember = ASSERT( not (null members) ) fst (head members)+    aMember = assert (not (null members) ) fst (head members)     (members, nonMembers) = partition (or . snd) membership      -- For each field, which constructors contain the field?     membership :: [(FieldLabelString, [Bool])]     membership = sortMembership $         map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $-          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds+          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds      fieldLabelSets :: [UniqSet FieldLabelString]     fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons@@ -1597,7 +1593,7 @@   = hang (text "No type has all these fields:")        2 (pprQuotedList fields)   where-    fields = map (hsRecFieldLbl . unLoc) rbinds+    fields = map (hfbLHS . unLoc) rbinds  badOverloadedUpdate :: SDoc badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -34,8 +34,6 @@         , tcForeignExports'         , tcCheckFEType         ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Tc/Gen/Head.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE GADTs               #-}@@ -24,7 +24,7 @@         , tcInferAppHead, tcInferAppHead_maybe        , tcInferId, tcCheckId-       , obviousSig, addAmbiguousNameErr+       , obviousSig        , tyConOf, tyConOfET, lookupParents, fieldNotInType        , notSelector, nonBidirectionalErr @@ -33,7 +33,6 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )  import GHC.Tc.Gen.HsType-import GHC.Tc.Gen.Pat import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan ) import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )@@ -41,11 +40,11 @@ import GHC.Tc.Utils.Unify import GHC.Types.Basic import GHC.Tc.Utils.Instantiate-import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst )+import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv    ( FamInstEnvs ) import GHC.Core.UsageEnv      ( unitUE )-import GHC.Rename.Env         ( addUsedGRE )-import GHC.Rename.Utils       ( addNameClashErrRn, unknownSubordinateErr )+import GHC.Rename.Utils       ( unknownSubordinateErr )+import GHC.Tc.Errors.Types import GHC.Tc.Solver          ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Zonk      ( hsLitType )@@ -55,7 +54,8 @@ import GHC.Hs import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Core.ConLike+import GHC.Core.PatSyn( PatSyn )+import GHC.Core.ConLike( ConLike(..) ) import GHC.Core.DataCon import GHC.Types.Name import GHC.Types.Name.Reader@@ -72,13 +72,11 @@ import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad  import Data.Function-import qualified Data.List.NonEmpty as NE -#include "GhclibHsVersions.h"- import GHC.Prelude  @@ -245,7 +243,7 @@ -- See Note [splitHsApps] splitHsApps e = go e (top_ctxt 0 e) []   where-    top_ctxt n (HsPar _ fun)               = top_lctxt n fun+    top_ctxt n (HsPar _ _ fun _)           = top_lctxt n fun     top_ctxt n (HsPragE _ _ fun)           = top_lctxt n fun     top_ctxt n (HsAppType _ fun _)         = top_lctxt (n+1) fun     top_ctxt n (HsApp _ fun _)             = top_lctxt (n+1) fun@@ -256,7 +254,7 @@      go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]        -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])-    go (HsPar _     (L l fun))    ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)   : args)+    go (HsPar _ _ (L l fun) _)    ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)   : args)     go (HsPragE _ p (L l fun))    ctxt args = go fun (set l ctxt) (EPrag      ctxt p   : args)     go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty  : args)     go (HsApp _ (L l fun) arg)    ctxt args = go fun (dec l ctxt) (mkEValArg  ctxt arg : args)@@ -294,7 +292,7 @@       EPrag ctxt' p         -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args       EWrap (EPar ctxt')-        -> rebuildHsApps (HsPar noAnn lfun) ctxt' args+        -> rebuildHsApps (gHsPar lfun) ctxt' args       EWrap (EExpand orig)         -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args       EWrap (EHsWrap wrap)@@ -373,22 +371,21 @@ ********************************************************************* -}  tcInferAppHead :: (HsExpr GhcRn, AppCtxt)-               -> [HsExprArg 'TcpRn] -> Maybe TcRhoType-               -- These two args are solely for tcInferRecSelId+               -> [HsExprArg 'TcpRn]                -> TcM (HsExpr GhcTc, TcSigmaType) -- Infer type of the head of an application --   i.e. the 'f' in (f e1 ... en) -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- We get back a /SigmaType/ because we have special cases for --   * A bare identifier (just look it up)---     This case also covers a record selector HsRecFld+--     This case also covers a record selector HsRecSel --   * An expression with a type signature (e :: ty) -- See Note [Application chains and heads] in GHC.Tc.Gen.App ----- Why do we need the arguments to infer the type of the head of--- the application?  For two reasons:---   * (Legitimate) The first arg has the source location of the head---   * (Disgusting) Needed for record disambiguation; see tcInferRecSelId+-- Why do we need the arguments to infer the type of the head of the+-- application? Simply to inform add_head_ctxt about whether or not+-- to put push a new "In the expression..." context. (We don't push a+-- new one if there are no arguments, because we already have.) -- -- Note that [] and (,,) are both HsVar: --   see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr@@ -397,24 +394,23 @@ --     cases are dealt with by splitHsApps. -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App-tcInferAppHead (fun,ctxt) args mb_res_ty+tcInferAppHead (fun,ctxt) args   = setSrcSpan (appCtxtLoc ctxt) $-    do { mb_tc_fun <- tcInferAppHead_maybe fun args mb_res_ty+    do { mb_tc_fun <- tcInferAppHead_maybe fun args        ; case mb_tc_fun of             Just (fun', fun_sigma) -> return (fun', fun_sigma)             Nothing -> add_head_ctxt fun args $                        tcInfer (tcExpr fun) }  tcInferAppHead_maybe :: HsExpr GhcRn-                     -> [HsExprArg 'TcpRn] -> Maybe TcRhoType-                        -- These two args are solely for tcInferRecSelId+                     -> [HsExprArg 'TcpRn]                      -> TcM (Maybe (HsExpr GhcTc, TcSigmaType)) -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- Returns Nothing for a complicated head-tcInferAppHead_maybe fun args mb_res_ty+tcInferAppHead_maybe fun args   = case fun of       HsVar _ (L _ nm)          -> Just <$> tcInferId nm-      HsRecFld _ f              -> Just <$> tcInferRecSelId f args mb_res_ty+      HsRecSel _ f              -> Just <$> tcInferRecSelId f       ExprWithTySig _ e hs_ty   -> add_head_ctxt fun args $                                    Just <$> tcExprWithSig e hs_ty       HsOverLit _ lit           -> Just <$> tcInferOverLit lit@@ -434,224 +430,46 @@ *                                                                      * ********************************************************************* -} -{--Note [Deprecating ambiguous fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the future, the -XDuplicateRecordFields extension will no longer support-disambiguating record fields during type-checking (as described in Note-[Disambiguating record fields]).  For now, the -Wambiguous-fields option will-emit a warning whenever an ambiguous field is resolved using type information.-In a subsequent GHC release, this functionality will be removed and the warning-will turn into an ambiguity error in the renamer.--For background information, see GHC proposal #366-(https://github.com/ghc-proposals/ghc-proposals/pull/366).---Note [Disambiguating record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB. The following is going to be removed: see-Note [Deprecating ambiguous fields].--When the -XDuplicateRecordFields extension is used, and the renamer-encounters a record selector or update that it cannot immediately-disambiguate (because it involves fields that belong to multiple-datatypes), it will defer resolution of the ambiguity to the-typechecker.  In this case, the `Ambiguous` constructor of-`AmbiguousFieldOcc` is used.--Consider the following definitions:--        data S = MkS { foo :: Int }-        data T = MkT { foo :: Int, bar :: Int }-        data U = MkU { bar :: Int, baz :: Int }--When the renamer sees `foo` as a selector or an update, it will not-know which parent datatype is in use.--For selectors, there are two possible ways to disambiguate:--1. Check if the pushed-in type is a function whose domain is a-   datatype, for example:--       f s = (foo :: S -> Int) s--       g :: T -> Int-       g = foo--    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.--2. Check if the selector is applied to an argument that has a type-   signature, for example:--       h = foo (s :: S)--    This is checked by `tcInferRecSelId`.---Updates are slightly more complex.  The `disambiguateRecordBinds`-function tries to determine the parent datatype in three ways:--1. Check for types that have all the fields being updated. For example:--        f x = x { foo = 3, bar = 2 }--   Here `f` must be updating `T` because neither `S` nor `U` have-   both fields. This may also discover that no possible type exists.-   For example the following will be rejected:--        f' x = x { foo = 3, baz = 3 }--2. Use the type being pushed in, if it is already a TyConApp. The-   following are valid updates to `T`:--        g :: T -> T-        g x = x { foo = 3 }--        g' x = x { foo = 3 } :: T--3. Use the type signature of the record expression, if it exists and-   is a TyConApp. Thus this is valid update to `T`:--        h x = (x :: T) { foo = 3 }---Note that we do not look up the types of variables being updated, and-no constraint-solving is performed, so for example the following will-be rejected as ambiguous:--     let bad (s :: S) = foo s--     let r :: T-         r = blah-     in r { foo = 3 }--     \r. (r { foo = 3 },  r :: T )--We could add further tests, of a more heuristic nature. For example,-rather than looking for an explicit signature, we could try to infer-the type of the argument to a selector or the record expression being-updated, in case we are lucky enough to get a TyConApp straight-away. However, it might be hard for programmers to predict whether a-particular update is sufficiently obvious for the signature to be-omitted. Moreover, this might change the behaviour of typechecker in-non-obvious ways.--See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat.--}--tcInferRecSelId :: AmbiguousFieldOcc GhcRn-                -> [HsExprArg 'TcpRn] -> Maybe TcRhoType+tcInferRecSelId :: FieldOcc GhcRn                 -> TcM (HsExpr GhcTc, TcSigmaType)-tcInferRecSelId (Unambiguous sel_name lbl) _args _mb_res_ty-   = do { sel_id <- tc_rec_sel_id lbl sel_name-        ; let expr = HsRecFld noExtField (Unambiguous sel_id lbl)-        ; return (expr, idType sel_id) }--tcInferRecSelId (Ambiguous _ lbl) args mb_res_ty-   = do { sel_name <- tcInferAmbiguousRecSelId lbl args mb_res_ty-        ; sel_id   <- tc_rec_sel_id lbl sel_name-        ; let expr = HsRecFld noExtField (Ambiguous sel_id lbl)-        ; return (expr, idType sel_id) }+tcInferRecSelId (FieldOcc sel_name lbl)+   = do { sel_id <- tc_rec_sel_id+        ; let expr = HsRecSel noExtField (FieldOcc sel_id lbl)+        ; return (expr, idType sel_id)+        }+     where+       occ :: OccName+       occ = rdrNameOcc (unLoc lbl) --------------------------tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM TcId--- Like tc_infer_id, but returns an Id not a HsExpr,--- so we can wrap it back up into a HsRecFld-tc_rec_sel_id lbl sel_name-  = do { thing <- tcLookup sel_name-       ; case thing of-             ATcId { tct_id = id }-               -> do { check_naughty occ id-                     ; check_local_id id-                     ; return id }+       tc_rec_sel_id :: TcM TcId+       -- Like tc_infer_id, but returns an Id not a HsExpr,+       -- so we can wrap it back up into a HsRecSel+       tc_rec_sel_id+         = do { thing <- tcLookup sel_name+              ; case thing of+                    ATcId { tct_id = id }+                      -> do { check_naughty occ id+                            ; check_local_id id+                            ; return id } -             AGlobal (AnId id)-               -> do { check_naughty occ id-                     ; return id }-                    -- A global cannot possibly be ill-staged-                    -- nor does it need the 'lifting' treatment-                    -- hence no checkTh stuff here+                    AGlobal (AnId id)+                      -> do { check_naughty occ id+                            ; return id }+                           -- A global cannot possibly be ill-staged+                           -- nor does it need the 'lifting' treatment+                           -- hence no checkTh stuff here -             _ -> failWithTc $-                  ppr thing <+> text "used where a value identifier was expected" }-  where-    occ = rdrNameOcc (unLoc lbl)+                    _ -> failWithTc $+                         ppr thing <+> text "used where a value identifier was expected" }  -------------------------tcInferAmbiguousRecSelId :: LocatedN RdrName-                         -> [HsExprArg 'TcpRn] -> Maybe TcRhoType-                         -> TcM Name--- Disgusting special case for ambiguous record selectors--- Given a RdrName that refers to multiple record fields, and the type--- of its argument, try to determine the name of the selector that is--- meant.--- See Note [Disambiguating record fields]-tcInferAmbiguousRecSelId lbl args mb_res_ty-  | arg1 : _ <- dropWhile (not . isVisibleArg) args -- A value arg is first-  , EValArg { eva_arg = ValArg (L _ arg) } <- arg1-  , Just sig_ty <- obviousSig arg  -- A type sig on the arg disambiguates-  = do { sig_tc_ty <- tcHsSigWcType (ExprSigCtxt NoRRC) sig_ty-       ; finish_ambiguous_selector lbl sig_tc_ty } -  | Just res_ty <- mb_res_ty-  , Just (arg_ty,_) <- tcSplitFunTy_maybe res_ty-  = finish_ambiguous_selector lbl (scaledThing arg_ty)--  | otherwise-  = ambiguousSelector lbl--finish_ambiguous_selector :: LocatedN RdrName -> Type -> TcM Name-finish_ambiguous_selector lr@(L _ rdr) parent_type- = do { fam_inst_envs <- tcGetFamInstEnvs-      ; case tyConOf fam_inst_envs parent_type of {-          Nothing -> ambiguousSelector lr ;-          Just p  ->--    do { xs <- lookupParents True rdr-       ; let parent = RecSelData p-       ; case lookup parent xs of {-           Nothing  -> failWithTc (fieldNotInType parent rdr) ;-           Just gre ->--    -- See Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class-    do { addUsedGRE True gre-       ; keepAlive (greMangledName gre)-         -- See Note [Deprecating ambiguous fields]-       ; warnIfFlag Opt_WarnAmbiguousFields True $-          vcat [ text "The field" <+> quotes (ppr rdr)-                   <+> text "belonging to type" <+> ppr parent_type-                   <+> text "is ambiguous."-               , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."-               , if isLocalGRE gre-                 then text "You can use explicit case analysis to resolve the ambiguity."-                 else text "You can use a qualified import or explicit case analysis to resolve the ambiguity."-               ]-       ; return (greMangledName gre) } } } } }---- This field name really is ambiguous, so add a suitable "ambiguous--- occurrence" error, then give up.-ambiguousSelector :: LocatedN RdrName -> TcM a-ambiguousSelector (L _ rdr)-  = do { addAmbiguousNameErr rdr-       ; failM }---- | This name really is ambiguous, so add a suitable "ambiguous--- occurrence" error, then continue-addAmbiguousNameErr :: RdrName -> TcM ()-addAmbiguousNameErr rdr-  = do { env <- getGlobalRdrEnv-       ; let gres = lookupGRE_RdrName rdr env-       ; case gres of-         [] -> panic "addAmbiguousNameErr: not found"-         gre : gres -> setErrCtxt [] $ addNameClashErrRn rdr $ gre NE.:| gres}- -- A type signature on the argument of an ambiguous record selector or -- the record expression in an update must be "obvious", i.e. the -- outermost constructor ignoring parentheses. obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) obviousSig (ExprWithTySig _ _ ty) = Just ty-obviousSig (HsPar _ p)            = obviousSig (unLoc p)+obviousSig (HsPar _ _ p _)        = obviousSig (unLoc p) obviousSig (HsPragE _ _ p)        = obviousSig (unLoc p) obviousSig _                      = Nothing @@ -897,12 +715,8 @@                -- Hence no checkTh stuff here               AGlobal (AConLike cl) -> case cl of-                 RealDataCon con -> return_data_con con-                 PatSynCon ps-                   | Just (expr, ty) <- patSynBuilderOcc ps-                   -> return (expr, ty)-                   | otherwise-                   -> failWithTc (nonBidirectionalErr id_name)+                 RealDataCon con -> tcInferDataCon con+                 PatSynCon ps    -> tcInferPatSyn id_name ps               AGlobal (ATyCon ty_con)                -> fail_tycon global_env ty_con@@ -931,49 +745,6 @@      return_id id = return (HsVar noExtField (noLocA id), idType id) -    return_data_con con-      = do { let tvs = dataConUserTyVarBinders con-                 theta = dataConOtherTheta con-                 args = dataConOrigArgTys con-                 res = dataConOrigResTy con--           -- See Note [Linear fields generalization]-           ; mul_vars <- newFlexiTyVarTys (length args) multiplicityTy-           ; let scaleArgs args' = zipWithEqual "return_data_con" combine mul_vars args'-                 combine var (Scaled One ty) = Scaled var ty-                 combine _   scaled_ty       = scaled_ty-                   -- The combine function implements the fact that, as-                   -- described in Note [Linear fields generalization], if a-                   -- field is not linear (last line) it isn't made polymorphic.--                 etaWrapper arg_tys = foldr (\scaled_ty wr -> WpFun WpHole wr scaled_ty empty) WpHole arg_tys--           -- See Note [Instantiating stupid theta]-           ; let shouldInstantiate = (not (null (dataConStupidTheta con)) ||-                                      isKindLevPoly (tyConResKind (dataConTyCon con)))-           ; case shouldInstantiate of-               True -> do { (subst, tvs') <- newMetaTyVars (binderVars tvs)-                           ; let tys'   = mkTyVarTys tvs'-                                 theta' = substTheta subst theta-                                 args'  = substScaledTys subst args-                                 res'   = substTy subst res-                           ; wrap <- instCall (OccurrenceOf id_name) tys' theta'-                           ; let scaled_arg_tys = scaleArgs args'-                                 eta_wrap = etaWrapper scaled_arg_tys-                           ; addDataConStupidTheta con tys'-                           ; return ( mkHsWrap (eta_wrap <.> wrap)-                                               (HsConLikeOut noExtField (RealDataCon con))-                                    , mkVisFunTys scaled_arg_tys res')-                           }-               False -> let scaled_arg_tys = scaleArgs args-                            wrap1 = mkWpTyApps (mkTyVarTys $ binderVars tvs)-                            eta_wrap = etaWrapper (map unrestricted theta ++ scaled_arg_tys)-                            wrap2 = mkWpTyLams $ binderVars tvs-                        in return ( mkHsWrap (wrap2 <.> eta_wrap <.> wrap1)-                                             (HsConLikeOut noExtField (RealDataCon con))-                                  , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res)-           }- check_local_id :: Id -> TcM () check_local_id id   = do { checkThLocalId id@@ -984,48 +755,101 @@   | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)   | otherwise                  = return () +tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)+-- See Note [Typechecking data constructors]+tcInferDataCon con+  = do { let tvs   = dataConUserTyVarBinders con+             theta = dataConOtherTheta con+             args  = dataConOrigArgTys con+             res   = dataConOrigResTy con+             stupid_theta = dataConStupidTheta con++       ; scaled_arg_tys <- mapM linear_to_poly args++       ; let full_theta  = stupid_theta ++ theta+             all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys+                -- stupid-theta must come first+                -- See Note [Instantiating stupid theta]++       ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)+                , mkInvisForAllTys tvs $ mkPhiTy full_theta $+                  mkVisFunTys scaled_arg_tys res ) }+  where+    linear_to_poly :: Scaled Type -> TcM (Scaled Type)+    -- linear_to_poly implements point (3,4)+    -- of Note [Typechecking data constructors]+    linear_to_poly (Scaled One ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy+                                        ; return (Scaled mul_var ty) }+    linear_to_poly scaled_ty       = return scaled_ty++tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)+tcInferPatSyn id_name ps+  = case patSynBuilderOcc ps of+       Just (expr,ty) -> return (expr,ty)+       Nothing        -> failWithTc (nonBidirectionalErr id_name)+ nonBidirectionalErr :: Outputable name => name -> SDoc nonBidirectionalErr name = text "non-bidirectional pattern synonym"                            <+> quotes (ppr name) <+> text "used in an expression" -{--Note [Linear fields generalization]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As per Note [Polymorphisation of linear fields], linear field of data-constructors get a polymorphic type when the data constructor is used as a term.+{- Note [Typechecking data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Polymorphisation of linear fields] in+GHC.Core.Multiplicity, linear fields of data constructors get a+polymorphic multiplicity when the data constructor is used as a term: -    Just :: forall {p} a. a #p-> Maybe a+    Just :: forall {p} a. a %p -> Maybe a -This rule is known only to the typechecker: Just keeps its linear type in Core.+So at an occurrence of a data constructor we do the following,+mostly in tcInferDataCon: -In order to desugar this generalised typing rule, we simply eta-expand:+1. Get its type, say+    K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a+   Note the %1: it is linear -    \a (x # p :: a) -> Just @a x+2. We are going to return a ConLikeTc, thus:+     XExpr (ConLikeTc K [r,a] [Scaled p a])+      :: forall (r :: RuntimeRep) (a :: Type r). a %p -> T r a+   where 'p' is a fresh multiplicity unification variable. -has the appropriate type. We insert these eta-expansion with WpFun wrappers.+   To get the returned ConLikeTc, we allocate a fresh multiplicity+   variable for each linear argument, and store the type, scaled by+   the fresh multiplicity variable in the ConLikeTc; along with+   the type of the ConLikeTc. This is done by linear_to_poly. -A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums,-certain newtypes with -XUnliftedNewtypes) then this strategy produces+3. If the argument is not linear (perhaps explicitly declared as+   non-linear by the user), don't bother with this. -    \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #)+4. The (ConLikeTc K [r,a] [Scaled p a]) is later desugared by+   GHC.HsToCore.Expr.dsConLike to:+     (/\r a. \(x %p :: a). K @r @a x)+   which has the desired type given in the previous bullet.+   The 'p' is the multiplicity unification variable, which+   will by now have been unified to something, or defaulted in+   `GHC.Tc.Utils.Zonk.commitFlexi`. So it won't just be an+   (unbound) variable. -Which has type+Wrinkles -    forall r1 r2 a b. a #p-> b #q-> (# a, b #)+* Why put [InvisTVBinder] in ConLikeTc, when we only need [TyVar] to+  desugar?  It's a bit of a toss-up, but having [InvisTvBinder] supports+  a future hsExprType :: HsExpr GhcTc -> Type -Which violates the levity-polymorphism restriction see Note [Levity polymorphism-checking] in DsMonad.+* Note that the [InvisTvBinder] is strictly redundant anyway; it's+  just the dataConUserTyVarBinders of the data constructor.  Similarly+  in the [Scaled TcType] field of ConLikeTc, the type comes directly+  from the data constructor.  The only bit that /isn't/ redundant is the+  fresh multiplicity variables! -So we really must instantiate r1 and r2 rather than quantify over them.  For-simplicity, we just instantiate the entire type, as described in Note-[Instantiating stupid theta]. It breaks visible type application with unboxed-tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used-anywhere.+  So an alternative would be to define ConLikeTc like this:+      | ConLikeTc [TcType]    -- Just the multiplicity variables+  But then the desugarer (and hsExprType, when we implement it) would+  need to repeat some of the work done here.  So for now at least+  ConLikeTc records this strictly-redundant info. -A better plan: let's force all representation variable to be *inferred*, so that-they are not subject to visible type applications. Then we can instantiate-inferred argument eagerly.+* See Note [Instantiating stupid theta] for an extra wrinkle + Note [Adding the implicit parameter to 'assert'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The typechecker transforms (assert e1 e2) to (assertError e1 e2).@@ -1037,15 +861,31 @@  Note [Instantiating stupid theta] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Normally, when we infer the type of an Id, we don't instantiate,-because we wish to allow for visible type application later on.-But if a datacon has a stupid theta, we're a bit stuck. We need-to emit the stupid theta constraints with instantiated types. It's-difficult to defer this to the lazy instantiation, because a stupid-theta has no spot to put it in a type. So we just instantiate eagerly-in this case. Thus, users cannot use visible type application with-a data constructor sporting a stupid theta. I won't feel so bad for-the users that complain.+Consider a data type with a "stupid theta":+  data Ord a => T a = MkT (Maybe a)++We want to generate an Ord constraint for every use of MkT; but+we also want to allow visible type application, such as+   MkT @Int++So we generate (ConLikeTc MkT [a] [Ord a, Maybe a]), with type+   forall a. Ord a => Maybe a -> T a++Now visible type application will work fine. But we desugar the+ConLikeTc to+   /\a \(d:Ord a) (x:Maybe a). MkT x+Notice that 'd' is dropped in this desugaring. We don't need it;+it was only there to generate a Wanted constraint. (That is why+it is stupid.)  To achieve this:++* We put the stupid-thata at the front of the list of argument+  types in ConLikeTc++* GHC.HsToCore.Expr.dsConLike generates /lambdas/ for all the+  arguments, but drops the stupid-theta arguments when building the+  /application/.++Nice. -}  {-@@ -1115,9 +955,7 @@                                        [getRuntimeRep id_ty, id_ty]                     -- Warning for implicit lift (#17804)-        ; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)-                          (text "The variable" <+> quotes (ppr id) <+>-                           text "is implicitly lifted in the TH quotation")+        ; addDetailedDiagnostic (TcRnImplicitLift id)                     -- Update the pending splices         ; ps <- readMutVar ps_var@@ -1184,7 +1022,7 @@                            Just env_ty -> zonkTcType env_ty                            Nothing     ->                              do { dumping <- doptM Opt_D_dump_tc_trace-                                ; MASSERT( dumping )+                                ; massert dumping                                 ; newFlexiTyVarTy liftedTypeKind }            ; let -- See Note [Splitting nested sigma types in mismatched                  --           function types]
compiler/GHC/Tc/Gen/HsType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-}@@ -74,8 +74,6 @@         funAppCtxt, addTyConFlavCtxt    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs@@ -119,6 +117,7 @@ import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Builtin.Names hiding ( wildCardName ) import GHC.Driver.Session@@ -1180,7 +1179,7 @@        ; return (mkForAllTys tv_bndrs ty') }  tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind-  | null (fromMaybeContext ctxt)+  | null (unLoc ctxt)   = tc_lhs_type mode rn_ty exp_kind    -- See Note [Body kind of a HsQualTy]@@ -1273,7 +1272,7 @@  --------- Constraint types tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind-  = do { MASSERT( isTypeLevel (mode_tyki mode) )+  = do { massert (isTypeLevel (mode_tyki mode))        ; ty' <- tc_lhs_type mode ty liftedTypeKind        ; let n' = mkStrLitTy $ hsIPNameFS n        ; ipClass <- tcLookupClass ipClassName@@ -1755,8 +1754,8 @@ mk_app_ty :: TcType -> TcType -> TcType -- This function just adds an ASSERT for mkAppTyM's precondition mk_app_ty fun arg-  = ASSERT2( isPiTy fun_kind-           ,  ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )+  = assertPpr (isPiTy fun_kind)+              (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $     mkAppTy fun arg   where     fun_kind = tcTypeKind fun@@ -1934,14 +1933,14 @@ ---------------------------  tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]-tcHsContext cxt = tc_hs_context typeLevelMode cxt+tcHsContext Nothing    = return []+tcHsContext (Just cxt) = tc_hs_context typeLevelMode cxt  tcLHsPredType :: LHsType GhcRn -> TcM PredType tcLHsPredType pred = tc_lhs_pred typeLevelMode pred -tc_hs_context :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM [PredType]-tc_hs_context _ Nothing = return []-tc_hs_context mode (Just ctxt) = mapM (tc_lhs_pred mode) (unLoc ctxt)+tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]+tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)  tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind@@ -2662,7 +2661,7 @@     invis_to_tcb :: TyCoBinder -> TcM TyConBinder     invis_to_tcb tb = do       (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing)-      MASSERT(null stv)+      massert (null stv)       return tcb      -- Check that the inline kind annotation on a binder is valid
compiler/GHC/Tc/Gen/Match.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE ConstraintKinds  #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes       #-}@@ -75,8 +75,6 @@  import Control.Monad import Control.Arrow ( second )--#include "GhclibHsVersions.h"  {- ************************************************************************
compiler/GHC/Tc/Gen/Pat.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-}@@ -25,8 +25,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )@@ -65,6 +63,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import qualified GHC.LanguageExtensions as LangExt import Control.Arrow  ( second ) import Control.Monad@@ -221,7 +220,7 @@   | otherwise                          -- No signature   = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of              Check pat_ty    -> promoteTcType bind_lvl pat_ty-             Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )+             Infer infer_res -> assert (bind_lvl == ir_lvl infer_res) $                                 -- If we were under a constructor that bumped the                                 -- level, we'd be in checking mode (see tcConArg)                                 -- hence this assertion@@ -339,7 +338,7 @@ tc_lpats :: [Scaled ExpSigmaType]          -> Checker [LPat GhcRn] [LPat GhcTc] tc_lpats tys penv pats-  = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )+  = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $     tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p)                penv                (zipEqual "tc_lpats" pats tys)@@ -364,9 +363,9 @@         ; pat_ty <- readExpType (scaledThing pat_ty)         ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) } -  ParPat x pat -> do+  ParPat x lpar pat rpar -> do         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside-        ; return (ParPat x pat', res) }+        ; return (ParPat x lpar pat' rpar, res) }    BangPat x pat -> do         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside@@ -536,8 +535,8 @@                 | otherwise        = unmangled_result          ; pat_ty <- readExpType (scaledThing pat_ty)-        ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced-          return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)+        ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced+        ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)         }    SumPat _ pat alt arity  -> do@@ -1055,7 +1054,7 @@ whose Origin is (OccurrenceOf f).  See also Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad+and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types -} ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function@@ -1246,13 +1245,13 @@       tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))                           (LHsRecField GhcTc (LPat GhcTc))       tc_field penv-               (L l (HsRecField ann (L loc (FieldOcc sel (L lr rdr))) pat pun))+               (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun))                thing_inside         = do { sel'   <- tcLookupId sel              ; pat_ty <- setSrcSpan loc $ find_field_ty sel                                             (occNameFS $ rdrNameOcc rdr)              ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside-             ; return (L l (HsRecField ann (L loc (FieldOcc sel' (L lr rdr))) pat'+             ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat'                                                                         pun), res) }  @@ -1271,7 +1270,7 @@                 -- The normal case, when the field comes from the right constructor            (pat_ty : extras) -> do                 traceTc "find_field" (ppr pat_ty <+> ppr extras)-                ASSERT( null extras ) (return pat_ty)+                assert (null extras) (return pat_ty)        field_tys :: [(FieldLabel, Scaled TcType)]       field_tys = zip (conLikeFieldLabels con_like) arg_tys
compiler/GHC/Tc/Gen/Sig.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Gen.Sig(@@ -24,8 +24,6 @@        mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs@@ -260,7 +258,7 @@ lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty   where-    go (L _ (HsQualTy { hst_ctxt = Just (L span _) })) = WantRRC $ locA span -- Found it!+    go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locA span -- Found it!     go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty  -- Look under foralls     go (L _ (HsParTy _ hs_ty)) = go hs_ty  -- Look under parens     go _ = NoRRC  -- Did not find it@@ -306,7 +304,7 @@                  , hst_body = ty } -> no_anon_wc_tele tele                                         && go ty       HsQualTy { hst_ctxt = ctxt-               , hst_body = ty }  -> gos (fromMaybeContext ctxt) && go ty+               , hst_body = ty }  -> gos (unLoc ctxt) && go ty       HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpanA ty       HsSpliceTy{} -> True       HsTyLit{} -> True@@ -577,7 +575,7 @@         -- add arity only for real INLINE pragmas, not INLINABLE       = case lookupNameEnv ar_env n of           Just ar -> inl_prag { inl_sat = Just ar }-          Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )+          Nothing -> warnPprTrace True (text "mkPragEnv no arity" <+> ppr n) $                      -- There really should be a binding for every INLINE pragma                      inl_prag       | otherwise
compiler/GHC/Tc/Gen/Splice.hs view
@@ -30,8 +30,6 @@      finishTH, runTopSplice       ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Errors@@ -120,9 +118,11 @@  import GHC.Utils.Misc import GHC.Utils.Panic as Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme import GHC.Utils.Outputable import GHC.Utils.Logger+import GHC.Utils.Exception (throwIO, ErrorCall(..))  import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) ) @@ -141,7 +141,6 @@ #endif  import Control.Monad-import Control.Exception import Data.Binary import Data.Binary.Get import Data.List        ( find )@@ -238,7 +237,7 @@        -- we want to reflect that in the overall type of the bracket.        ; ps' <- case quoteWrapperTyVarTy <$> brack_info of                   Just m_var -> mapM (tcPendingSplice m_var) ps-                  Nothing -> ASSERT(null ps) return []+                  Nothing -> assert (null ps) $ return []         ; traceTc "tc_bracket done untyped" (ppr expected_type) @@ -2013,7 +2012,7 @@                 -- constructors can be declared infix.                 -- See Note [Infix GADT constructors] in GHC.Tc.TyCl.               | dataConIsInfix dc && not isGadtDataCon ->-                  ASSERT( r_arg_tys `lengthIs` 2 ) do+                  assert (r_arg_tys `lengthIs` 2) $ do                   { let [r_a1, r_a2] = r_arg_tys                         [s1,   s2]   = dcdBangs                   ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }@@ -2024,7 +2023,7 @@                   return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)         ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)-                               | otherwise     = ASSERT( all isTyVar ex_tvs )+                               | otherwise     = assert (all isTyVar ex_tvs)                                                  -- no covars for haskell syntax                                                  (map mk_specified ex_tvs, theta)              ret_con | null ex_tvs' && null theta' = return main_con@@ -2032,7 +2031,7 @@                          { cxt <- reifyCxt theta'                          ; ex_tvs'' <- reifyTyVarBndrs ex_tvs'                          ; return (TH.ForallC ex_tvs'' cxt main_con) }-       ; ASSERT( r_arg_tys `equalLength` dcdBangs )+       ; assert (r_arg_tys `equalLength` dcdBangs)          ret_con }   where     mk_specified tv = Bndr tv SpecifiedSpec@@ -2493,7 +2492,7 @@         -- have free variables, we may need to generate NameL's for them.   where     name    = getName thing-    mod     = ASSERT( isExternalName name ) nameModule name+    mod     = assert (isExternalName name) $ nameModule name     pkg_str = unitString (moduleUnit mod)     mod_str = moduleNameString (moduleName mod)     occ_str = occNameString occ@@ -2511,7 +2510,7 @@   | otherwise = TH.mkNameG_v pkg_str mod_str occ_str   where     name    = flSelector fl-    mod     = ASSERT( isExternalName name ) nameModule name+    mod     = assert (isExternalName name) $ nameModule name     pkg_str = unitString (moduleUnit mod)     mod_str = moduleNameString (moduleName mod)     occ_str = unpackFS (flLabel fl)
compiler/GHC/Tc/Gen/Splice.hs-boot view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Gen.Splice where
compiler/GHC/Tc/Instance/Class.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Tc.Instance.Class (@@ -9,8 +9,6 @@      AssocInstInfo(..), isNotAssociated   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -101,7 +99,7 @@ data InstanceWhat   = BuiltinInstance   | BuiltinEqInstance   -- A built-in "equality instance"; see the-                        -- GHC.Tc.Solver.Monad Note [Solved dictionaries]+                        -- GHC.Tc.Solver.InertSet Note [Solved dictionaries]   | LocalInstance   | TopLevInstance { iw_dfun_id   :: DFunId                    , iw_safe_over :: SafeOverlapping }@@ -126,7 +124,7 @@ safeOverlap _                                      = True  instanceReturnsDictCon :: InstanceWhat -> Bool--- See Note [Solved dictionaries] in GHC.Tc.Solver.Monad+-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet instanceReturnsDictCon (TopLevInstance {}) = True instanceReturnsDictCon BuiltinInstance     = True instanceReturnsDictCon BuiltinEqInstance   = False
compiler/GHC/Tc/Instance/Family.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GADTs, ViewPatterns #-}+{-# LANGUAGE GADTs, ViewPatterns #-}  -- | The @FamInst@ type: family instance heads module GHC.Tc.Instance.Family (@@ -49,6 +49,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.FV  import GHC.Data.Bag( Bag, unionBags, unitBag )@@ -61,8 +62,6 @@  import qualified GHC.LanguageExtensions  as LangExt -#include "GhclibHsVersions.h"- {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -511,7 +510,7 @@   , let rep_tc = dataFamInstRepTyCon rep_fam         co     = mkUnbranchedAxInstCo Representational ax rep_args                                       (mkCoVarCos cvs)-  = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in GHC.Core.FamInstEnv+  = assert (null rep_cos) $ -- See Note [Constrained family instances] in GHC.Core.FamInstEnv     Just (rep_tc, rep_args, co)    | otherwise@@ -752,7 +751,7 @@    -> [Bool]       -- ^ Injectivity annotation    -> TcM () reportInjectivityErrors dflags fi_ax axiom inj-  = ASSERT2( any id inj, text "No injective type variables" )+  = assertPpr (any id inj) (text "No injective type variables") $     do let lhs             = coAxBranchLHS axiom            rhs             = coAxBranchRHS axiom            fam_tc          = coAxiomTyCon fi_ax
compiler/GHC/Tc/Instance/FunDeps.hs view
@@ -5,8 +5,8 @@  -} -{-# LANGUAGE CPP #-} + -- | Functional dependencies -- -- It's better to read it as: "if we know these, then we're going to know these"@@ -21,8 +21,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Name@@ -266,9 +264,9 @@   = []          -- Filter out ones that can't possibly match,    | otherwise-  = ASSERT2( equalLength tys_inst tys_actual &&-             equalLength tys_inst clas_tvs-            , ppr tys_inst <+> ppr tys_actual )+  = assertPpr (equalLength tys_inst tys_actual &&+               equalLength tys_inst clas_tvs)+              (ppr tys_inst <+> ppr tys_actual) $      case tcMatchTyKis ltys1 ltys2 of         Nothing  -> []
compiler/GHC/Tc/Instance/Typeable.hs view
@@ -3,14 +3,12 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where--#include "GhclibHsVersions.h"  import GHC.Prelude import GHC.Platform
compiler/GHC/Tc/Module.hs view
@@ -131,6 +131,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Logger @@ -178,8 +179,6 @@ import Control.DeepSeq import Control.Monad -#include "GhclibHsVersions.h"- {- ************************************************************************ *                                                                      *@@ -215,7 +214,7 @@     logger  = hsc_logger hsc_env     home_unit = hsc_home_unit hsc_env     err_msg = mkPlainErrorMsgEnvelope loc $-              TcRnUnknownMessage $ mkPlainError $+              TcRnUnknownMessage $ mkPlainError noHints $                 text "Module does not have a RealSrcSpan:" <+> ppr this_mod      pair :: (Module, SrcSpan)@@ -367,7 +366,7 @@          ; this_mod <- getModule         ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot-              ; dep_mods = imp_dep_mods imports+              ; dep_mods = imp_direct_dep_mods imports                  -- We want instance declarations from all home-package                 -- modules below this one, including boot modules, except@@ -376,17 +375,15 @@                 -- filtering also ensures that we don't see instances from                 -- modules batch (@--make@) compiled before this one, but                 -- which are not below this one.-              ; want_instances :: ModuleName -> Bool-              ; want_instances mod = mod `elemUFM` dep_mods-                                   && mod /= moduleName this_mod-              ; (home_insts, home_fam_insts) = hptInstances hsc_env-                                                            want_instances+              ; (home_insts, home_fam_insts) = hptInstancesBelow hsc_env (moduleName this_mod) (eltsUFM dep_mods)               } ;                  -- Record boot-file info in the EPS, so that it's                 -- visible to loadHiBootInterface in tcRnSrcDecls,                 -- and any other incrementally-performed imports-        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;+              ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {+                  updateEps_ $ \eps  -> eps { eps_is_boot = imp_boot_mods imports }+               }                  -- Update the gbl env         ; updGblEnv ( \ gbl ->@@ -400,7 +397,7 @@               tcg_hpc          = hpc_info             }) $ do { -        ; traceRn "rn1" (ppr (imp_dep_mods imports))+        ; traceRn "rn1" (ppr (imp_direct_dep_mods imports))                 -- Fail if there are any errors so far                 -- The error printing (if needed) takes advantage                 -- of the tcg_env we have now set@@ -868,9 +865,6 @@      check_export boot_avail     -- boot_avail is exported by the boot iface       | name `elem` boot_dfun_names = return ()-      | isWiredInName name          = return () -- No checking for wired-in names.  In particular,-                                                -- 'error' is handled by a rather gross hack-                                                -- (see comments in GHC.Err.hs-boot)          -- Check that the actual module exports the same thing       | not (null missing_names)@@ -977,7 +971,7 @@ checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc  checkBootDecl _ (AnId id1) (AnId id2)-  = ASSERT(id1 == id2)+  = assert (id1 == id2) $     check (idType id1 `eqType` idType id2)           (text "The two types are different") @@ -1117,7 +1111,7 @@   | Just syn_rhs1 <- synTyConRhs_maybe tc1   , Just syn_rhs2 <- synTyConRhs_maybe tc2   , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)-  = ASSERT(tc1 == tc2)+  = assert (tc1 == tc2) $     checkRoles roles1 roles2 `andThenCheck`     check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say   -- This allows abstract 'data T a' to be implemented using 'type T = ...'@@ -1147,7 +1141,7 @@    | Just fam_flav1 <- famTyConFlav_maybe tc1   , Just fam_flav2 <- famTyConFlav_maybe tc2-  = ASSERT(tc1 == tc2)+  = assert (tc1 == tc2) $     let eqFamFlav OpenSynFamilyTyCon   OpenSynFamilyTyCon = True         eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True         -- This case only happens for hsig merging:@@ -1173,7 +1167,7 @@    | isAlgTyCon tc1 && isAlgTyCon tc2   , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)-  = ASSERT(tc1 == tc2)+  = assert (tc1 == tc2) $     checkRoles roles1 roles2 `andThenCheck`     check (eqListBy (eqTypeX env)                      (tyConStupidTheta tc1) (tyConStupidTheta tc2))@@ -1282,7 +1276,7 @@                 `andThenCheck`         -- Don't report roles errors unless the type synonym is nullary         checkUnless (not (null tvs)) $-            ASSERT( null roles2 )+            assert (null roles2) $             -- If we have something like:             --             --  signature H where@@ -1825,7 +1819,7 @@               generateMainBinding tcg_env main_name             | otherwise-           -> ASSERT( null exported_mains )+           -> assert (null exported_mains) $               -- A fully-checked export list can't contain more               -- than one function with the same OccName               do { complain_no_main dflags main_mod main_occ@@ -2071,7 +2065,7 @@         ; setEnvs (gbl_env', lcl_env') thing_inside }   where-    (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)+    (home_insts, home_fam_insts) = hptAllInstances hsc_env      icxt                     = hsc_IC hsc_env     (ic_insts, ic_finsts)    = ic_instances icxt@@ -2651,7 +2645,7 @@         -- Since all the wanteds are equalities, the returned bindings will be empty        ; empty_binds <- simplifyTop wanted-       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )+       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)         -- Do kind generalisation; see Note [Kind-generalise in tcRnType]        ; kvs <- kindGeneralizeAll kind@@ -2953,9 +2947,9 @@          , ppr_fam_insts fam_insts          , ppr_rules rules          , text "Dependent modules:" <+>-                pprUFM (imp_dep_mods imports) (ppr . sort)+                pprUFM (imp_direct_dep_mods imports) (ppr . sort)          , text "Dependent packages:" <+>-                ppr (S.toList $ imp_dep_pkgs imports)]+                ppr (S.toList $ imp_dep_direct_pkgs imports)]                 -- The use of sort is just to reduce unnecessary                 -- wobbling in testsuite output @@ -3158,5 +3152,5 @@       singleMessage $       mkPlainMsgEnvelope dflags noSrcSpan $       TcRnUnknownMessage $-      mkPlainDiagnostic WarningWithoutFlag $+      mkPlainDiagnostic WarningWithoutFlag noHints $       Outputable.text unsafeText
compiler/GHC/Tc/Plugin.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ -- | This module provides an interface for typechecker plugins to -- access select functions of the 'TcM', principally those to do with -- reading parts of the state.
compiler/GHC/Tc/Solver.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.Tc.Solver(        InferMode(..), simplifyInfer, findInferredDiff,        growThetaTyVars,@@ -26,8 +26,6 @@        approximateWC, runTcSDeriveds   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Data.Bag@@ -48,6 +46,7 @@ import GHC.Tc.Utils.Unify        ( buildTvImplication ) import GHC.Tc.Utils.TcMType as TcM import GHC.Tc.Utils.Monad   as TcM+import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad  as TcS import GHC.Tc.Types.Constraint import GHC.Core.Predicate@@ -120,7 +119,7 @@   = do { empty_binds <- simplifyTop (mkImplicWC implics)         -- Since all the inputs are implications the returned bindings will be empty-       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )+       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)         ; return () } @@ -1772,7 +1771,7 @@        ; (unifs1, wc1) <- reportUnifications $  -- See Note [Superclass iteration]                           solveSimpleWanteds simples                 -- Any insoluble constraints are in 'simples' and so get rewritten-                -- See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad+                -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet         ; wc2 <- if not definitely_redo_implications  -- See Note [Superclass iteration]                    && unifs1 == 0                    -- for this conditional@@ -1932,7 +1931,8 @@     -- remaining commented out for now.     {-     check_tc_level = do { cur_lvl <- TcS.getTcLevel-                        ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }+                        ; massertPpr (tclvl == pushTcLevel cur_lvl)+                                     (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) }     -}  ----------------------@@ -1946,7 +1946,7 @@                                     , ic_info       = info                                     , ic_wanted     = wc                                     , ic_given      = givens })- | ASSERT2( not (isSolvedStatus status ), ppr info )+ | assertPpr (not (isSolvedStatus status)) (ppr info) $    -- Precondition: we only set the status if it is not already solved    not (isSolvedWC pruned_wc)  = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -10,8 +10,6 @@      solveCallStack    -- For GHC.Tc.Solver   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Tc.Types.Constraint@@ -22,6 +20,7 @@ import GHC.Core.Type import GHC.Tc.Solver.Rewrite import GHC.Tc.Solver.Monad+import GHC.Tc.Solver.InertSet import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm import GHC.Core.Class@@ -39,6 +38,7 @@ import GHC.Types.Var.Set( delVarSetList, anyVarSet ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Builtin.Types ( anyTypeOfKind ) import GHC.Driver.Session( DynFlags ) import GHC.Types.Name.Set@@ -160,7 +160,7 @@   -- call, we need to push the current call-site onto the stack instead   -- of solving it directly from a given.   -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-  -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad+  -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types   = do { -- First we emit a new constraint that will capture the          -- given CallStack.        ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))@@ -208,7 +208,7 @@  canClass ev cls tys pend_sc fds   =   -- all classes do *nominal* matching-    ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )+    assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $     do { (xis, cos) <- rewriteArgsNom ev cls_tc tys        ; let co = mkTcTyConAppCo Nominal cls_tc cos              xi = mkClassPred cls xis@@ -503,8 +503,8 @@     go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })       = mkStrictSuperClasses ev [] [] cls tys     go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))-      = ASSERT2( isClassPred pred, ppr pred )  -- The cts should all have-                                               -- class pred heads+      = assertPpr (isClassPred pred) (ppr pred) $  -- The cts should all have+                                                   -- class pred heads         mkStrictSuperClasses ev tvs theta cls tys       where         (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)@@ -596,7 +596,7 @@    | otherwise -- Wanted/Derived case, just add Derived superclasses               -- that can lead to improvement.-  = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )+  = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $     concatMapM do_one_derived (immSuperClasses cls tys)   where     loc = ctEvLoc ev@@ -1214,7 +1214,7 @@              -- Done: unify phi1 ~ phi2             go [] subst bndrs2-              = ASSERT( null bndrs2 )+              = assert (null bndrs2 )                 unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)              go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []@@ -1851,7 +1851,7 @@                           -> TcS (StopOrContinue Ct) -- Precondition: tys1 and tys2 are the same length, hence "OK" canDecomposableTyConAppOK ev eq_rel tc tys1 tys2-  = ASSERT( tys1 `equalLength` tys2 )+  = assert (tys1 `equalLength` tys2) $     do { traceTcS "canDecomposableTyConAppOK"                   (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)        ; case ev of@@ -1974,7 +1974,7 @@ all the way down, so that it accurately reflects  (a) the mutable reference substitution in force at start of solving  (b) any ty-binds in force at this point in solving-See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad.+See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet. And if we don't do this there is a bad danger that GHC.Tc.Solver.applyTyVarDefaulting will find a variable that has in fact been substituted.@@ -2508,7 +2508,7 @@ --   TyEq:H:  Checked here. canEqOK :: DynFlags -> EqRel -> CanEqLHS -> Xi -> CanEqOK canEqOK dflags eq_rel lhs rhs-  = ASSERT( good_rhs )+  = assert good_rhs $     case checkTypeEq dflags YesTypeFamilies lhs rhs of       CTE_OK  -> CanEqOK       CTE_Bad -> CanEqNotOK OtherCIS@@ -3037,7 +3037,7 @@                -- The "_SI" variant ensures that we make a new Wanted                -- with the same shadow-info as the existing one                -- with the same shadow-info as the existing one (#16735)-       ; MASSERT( tcCoercionRole co == ctEvRole ev )+       ; massert (tcCoercionRole co == ctEvRole ev)        ; setWantedEvTerm dest             (mkEvCast (getEvExpr mb_new_ev)                       (tcDowngradeRole Representational (ctEvRole ev) co))
+ compiler/GHC/Tc/Solver/InertSet.hs view
@@ -0,0 +1,1633 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Tc.Solver.InertSet (+    -- * The work list+    WorkList(..), isEmptyWorkList, emptyWorkList,+    extendWorkListNonEq, extendWorkListCt,+    extendWorkListCts, extendWorkListEq, extendWorkListDeriveds,+    appendWorkList, extendWorkListImplic,+    workListSize,+    selectWorkItem,++    -- * The inert set+    InertSet(..),+    InertCans(..),+    InertEqs,+    emptyInert,+    addInertItem,++    matchableGivens,+    mightEqualLater,+    prohibitedSuperClassSolve,++    -- * Inert equalities+    foldTyEqs, delEq, findEq,++    -- * Kick-out+    kickOutRewritableLHS++  ) where++import GHC.Prelude++import GHC.Tc.Solver.Types++import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType+import GHC.Types.Var+import GHC.Types.Var.Env++import GHC.Core.Predicate+import GHC.Core.TyCo.FVs+import qualified GHC.Core.TyCo.Rep as Rep+import GHC.Core.TyCon+import GHC.Core.Unify++import GHC.Data.Bag+import GHC.Utils.Misc       ( chkAppend, partitionWith )+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.List          ( partition )+import Data.List.NonEmpty ( NonEmpty(..) )++{-+************************************************************************+*                                                                      *+*                            Worklists                                *+*  Canonical and non-canonical constraints that the simplifier has to  *+*  work on. Including their simplification depths.                     *+*                                                                      *+*                                                                      *+************************************************************************++Note [WorkList priorities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+A WorkList contains canonical and non-canonical items (of all flavours).+Notice that each Ct now has a simplification depth. We may+consider using this depth for prioritization as well in the future.++As a simple form of priority queue, our worklist separates out++* equalities (wl_eqs); see Note [Prioritise equalities]+* all the rest (wl_rest)++Note [Prioritise equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very important to process equalities /first/:++* (Efficiency)  The general reason to do so is that if we process a+  class constraint first, we may end up putting it into the inert set+  and then kicking it out later.  That's extra work compared to just+  doing the equality first.++* (Avoiding fundep iteration) As #14723 showed, it's possible to+  get non-termination if we+      - Emit the Derived fundep equalities for a class constraint,+        generating some fresh unification variables.+      - That leads to some unification+      - Which kicks out the class constraint+      - Which isn't solved (because there are still some more Derived+        equalities in the work-list), but generates yet more fundeps+  Solution: prioritise derived equalities over class constraints++* (Class equalities) We need to prioritise equalities even if they+  are hidden inside a class constraint;+  see Note [Prioritise class equalities]++* (Kick-out) We want to apply this priority scheme to kicked-out+  constraints too (see the call to extendWorkListCt in kick_out_rewritable+  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become+  homo-kinded when kicked out, and hence we want to prioritise it.++* (Derived equalities) Originally we tried to postpone processing+  Derived equalities, in the hope that we might never need to deal+  with them at all; but in fact we must process Derived equalities+  eagerly, partly for the (Efficiency) reason, and more importantly+  for (Avoiding fundep iteration).++Note [Prioritise class equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prioritise equalities in the solver (see selectWorkItem). But class+constraints like (a ~ b) and (a ~~ b) are actually equalities too;+see Note [The equality types story] in GHC.Builtin.Types.Prim.++Failing to prioritise these is inefficient (more kick-outs etc).+But, worse, it can prevent us spotting a "recursive knot" among+Wanted constraints.  See comment:10 of #12734 for a worked-out+example.++So we arrange to put these particular class constraints in the wl_eqs.++  NB: since we do not currently apply the substitution to the+  inert_solved_dicts, the knot-tying still seems a bit fragile.+  But this makes it better.++Note [Residual implications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The wl_implics in the WorkList are the residual implication+constraints that are generated while solving or canonicalising the+current worklist.  Specifically, when canonicalising+   (forall a. t1 ~ forall a. t2)+from which we get the implication+   (forall a. t1 ~ t2)+See GHC.Tc.Solver.Monad.deferTcSForAllEq++-}++-- See Note [WorkList priorities]+data WorkList+  = WL { wl_eqs     :: [Ct]  -- CEqCan, CDictCan, CIrredCan+                             -- Given, Wanted, and Derived+                       -- Contains both equality constraints and their+                       -- class-level variants (a~b) and (a~~b);+                       -- See Note [Prioritise equalities]+                       -- See Note [Prioritise class equalities]++       , wl_rest    :: [Ct]++       , wl_implics :: Bag Implication  -- See Note [Residual implications]+    }++appendWorkList :: WorkList -> WorkList -> WorkList+appendWorkList+    (WL { wl_eqs = eqs1, wl_rest = rest1+        , wl_implics = implics1 })+    (WL { wl_eqs = eqs2, wl_rest = rest2+        , wl_implics = implics2 })+   = WL { wl_eqs     = eqs1     ++ eqs2+        , wl_rest    = rest1    ++ rest2+        , wl_implics = implics1 `unionBags`   implics2 }++workListSize :: WorkList -> Int+workListSize (WL { wl_eqs = eqs, wl_rest = rest })+  = length eqs + length rest++extendWorkListEq :: Ct -> WorkList -> WorkList+extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }++extendWorkListNonEq :: Ct -> WorkList -> WorkList+-- Extension by non equality+extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }++extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList+extendWorkListDeriveds evs wl+  = extendWorkListCts (map mkNonCanonical evs) wl++extendWorkListImplic :: Implication -> WorkList -> WorkList+extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }++extendWorkListCt :: Ct -> WorkList -> WorkList+-- Agnostic+extendWorkListCt ct wl+ = case classifyPredType (ctPred ct) of+     EqPred {}+       -> extendWorkListEq ct wl++     ClassPred cls _  -- See Note [Prioritise class equalities]+       |  isEqPredClass cls+       -> extendWorkListEq ct wl++     _ -> extendWorkListNonEq ct wl++extendWorkListCts :: [Ct] -> WorkList -> WorkList+-- Agnostic+extendWorkListCts cts wl = foldr extendWorkListCt wl cts++isEmptyWorkList :: WorkList -> Bool+isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })+  = null eqs && null rest && isEmptyBag implics++emptyWorkList :: WorkList+emptyWorkList = WL { wl_eqs  = [], wl_rest = [], wl_implics = emptyBag }++selectWorkItem :: WorkList -> Maybe (Ct, WorkList)+-- See Note [Prioritise equalities]+selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest })+  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })+  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })+  | otherwise      = Nothing++-- Pretty printing+instance Outputable WorkList where+  ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })+   = text "WL" <+> (braces $+     vcat [ ppUnless (null eqs) $+            text "Eqs =" <+> vcat (map ppr eqs)+          , ppUnless (null rest) $+            text "Non-eqs =" <+> vcat (map ppr rest)+          , ppUnless (isEmptyBag implics) $+            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))+                       (text "(Implics omitted)")+          ])++{- *********************************************************************+*                                                                      *+                InertSet: the inert set+*                                                                      *+*                                                                      *+********************************************************************* -}++data InertSet+  = IS { inert_cans :: InertCans+              -- Canonical Given, Wanted, Derived+              -- Sometimes called "the inert set"++       , inert_cycle_breakers :: [(TcTyVar, TcType)]+              -- a list of CycleBreakerTv / original family applications+              -- used to undo the cycle-breaking needed to handle+              -- Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical++       , inert_famapp_cache :: FunEqMap (TcCoercion, TcType)+              -- Just a hash-cons cache for use when reducing family applications+              -- only+              --+              -- If    F tys :-> (co, rhs, flav),+              -- then  co :: rhs ~N F tys+              -- all evidence is from instances or Givens; no coercion holes here+              -- (We have no way of "kicking out" from the cache, so putting+              --  wanteds here means we can end up solving a Wanted with itself. Bad)++       , inert_solved_dicts   :: DictMap CtEvidence+              -- All Wanteds, of form ev :: C t1 .. tn+              -- See Note [Solved dictionaries]+              -- and Note [Do not add superclasses of solved dictionaries]+       }++instance Outputable InertSet where+  ppr (IS { inert_cans = ics+          , inert_solved_dicts = solved_dicts })+      = vcat [ ppr ics+             , ppUnless (null dicts) $+               text "Solved dicts =" <+> vcat (map ppr dicts) ]+         where+           dicts = bagToList (dictsToBag solved_dicts)++emptyInertCans :: InertCans+emptyInertCans+  = IC { inert_eqs          = emptyDVarEnv+       , inert_given_eq_lvl = topTcLevel+       , inert_given_eqs    = False+       , inert_dicts        = emptyDictMap+       , inert_safehask     = emptyDictMap+       , inert_funeqs       = emptyFunEqs+       , inert_insts        = []+       , inert_irreds       = emptyCts }++emptyInert :: InertSet+emptyInert+  = IS { inert_cans           = emptyInertCans+       , inert_cycle_breakers = []+       , inert_famapp_cache   = emptyFunEqs+       , inert_solved_dicts   = emptyDictMap }+++{- Note [Solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we apply a top-level instance declaration, we add the "solved"+dictionary to the inert_solved_dicts.  In general, we use it to avoid+creating a new EvVar when we have a new goal that we have solved in+the past.++But in particular, we can use it to create *recursive* dictionaries.+The simplest, degenerate case is+    instance C [a] => C [a] where ...+If we have+    [W] d1 :: C [x]+then we can apply the instance to get+    d1 = $dfCList d+    [W] d2 :: C [x]+Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.+    d1 = $dfCList d+    d2 = d1++See Note [Example of recursive dictionaries]++VERY IMPORTANT INVARIANT:++ (Solved Dictionary Invariant)+    Every member of the inert_solved_dicts is the result+    of applying an instance declaration that "takes a step"++    An instance "takes a step" if it has the form+        dfunDList d1 d2 = MkD (...) (...) (...)+    That is, the dfun is lazy in its arguments, and guarantees to+    immediately return a dictionary constructor.  NB: all dictionary+    data constructors are lazy in their arguments.++    This property is crucial to ensure that all dictionaries are+    non-bottom, which in turn ensures that the whole "recursive+    dictionary" idea works at all, even if we get something like+        rec { d = dfunDList d dx }+    See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.++ Reason:+   - All instances, except two exceptions listed below, "take a step"+     in the above sense++   - Exception 1: local quantified constraints have no such guarantee;+     indeed, adding a "solved dictionary" when appling a quantified+     constraint led to the ability to define unsafeCoerce+     in #17267.++   - Exception 2: the magic built-in instance for (~) has no+     such guarantee.  It behaves as if we had+         class    (a ~# b) => (a ~ b) where {}+         instance (a ~# b) => (a ~ b) where {}+     The "dfun" for the instance is strict in the coercion.+     Anyway there's no point in recording a "solved dict" for+     (t1 ~ t2); it's not going to allow a recursive dictionary+     to be constructed.  Ditto (~~) and Coercible.++THEREFORE we only add a "solved dictionary"+  - when applying an instance declaration+  - subject to Exceptions 1 and 2 above++In implementation terms+  - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary,+    conditional on the kind of instance++  - It is only called when applying an instance decl,+    in GHC.Tc.Solver.Interact.doTopReactDict++  - ClsInst.InstanceWhat says what kind of instance was+    used to solve the constraint.  In particular+      * LocalInstance identifies quantified constraints+      * BuiltinEqInstance identifies the strange built-in+        instances for equality.++  - ClsInst.instanceReturnsDictCon says which kind of+    instance guarantees to return a dictionary constructor++Other notes about solved dictionaries++* See also Note [Do not add superclasses of solved dictionaries]++* The inert_solved_dicts field is not rewritten by equalities,+  so it may get out of date.++* The inert_solved_dicts are all Wanteds, never givens++* We only cache dictionaries from top-level instances, not from+  local quantified constraints.  Reason: if we cached the latter+  we'd need to purge the cache when bringing new quantified+  constraints into scope, because quantified constraints "shadow"+  top-level instances.++Note [Do not add superclasses of solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every member of inert_solved_dicts is the result of applying a+dictionary function, NOT of applying superclass selection to anything.+Consider++        class Ord a => C a where+        instance Ord [a] => C [a] where ...++Suppose we are trying to solve+  [G] d1 : Ord a+  [W] d2 : C [a]++Then we'll use the instance decl to give++  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3+  [W] d3 : Ord [a]++We must not add d4 : Ord [a] to the 'solved' set (by taking the+superclass of d2), otherwise we'll use it to solve d3, without ever+using d1, which would be a catastrophe.++Solution: when extending the solved dictionaries, do not add superclasses.+That's why each element of the inert_solved_dicts is the result of applying+a dictionary function.++Note [Example of recursive dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--- Example 1++    data D r = ZeroD | SuccD (r (D r));++    instance (Eq (r (D r))) => Eq (D r) where+        ZeroD     == ZeroD     = True+        (SuccD a) == (SuccD b) = a == b+        _         == _         = False;++    equalDC :: D [] -> D [] -> Bool;+    equalDC = (==);++We need to prove (Eq (D [])). Here's how we go:++   [W] d1 : Eq (D [])+By instance decl of Eq (D r):+   [W] d2 : Eq [D []]      where   d1 = dfEqD d2+By instance decl of Eq [a]:+   [W] d3 : Eq (D [])      where   d2 = dfEqList d3+                                   d1 = dfEqD d2+Now this wanted can interact with our "solved" d1 to get:+    d3 = d1++-- Example 2:+This code arises in the context of "Scrap Your Boilerplate with Class"++    class Sat a+    class Data ctx a+    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2++    class Data Maybe a => Foo a++    instance Foo t => Sat (Maybe t)                             -- dfunSat++    instance Data Maybe a => Foo a                              -- dfunFoo1+    instance Foo a        => Foo [a]                            -- dfunFoo2+    instance                 Foo [Char]                         -- dfunFoo3++Consider generating the superclasses of the instance declaration+         instance Foo a => Foo [a]++So our problem is this+    [G] d0 : Foo t+    [W] d1 : Data Maybe [t]   -- Desired superclass++We may add the given in the inert set, along with its superclasses+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  WorkList+    [W] d1 : Data Maybe [t]++Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+  WorkList:+    [W] d2 : Sat (Maybe [t])+    [W] d3 : Data Maybe t++Now, we may simplify d2 using dfunSat; d2 := dfunSat d4+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList:+    [W] d3 : Data Maybe t+    [W] d4 : Foo [t]++Now, we can just solve d3 from d01; d3 := d01+  Inert+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList+    [W] d4 : Foo [t]++Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5+  Inert+    [G] d0  : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+        d4 : Foo [t]+  WorkList:+    [W] d5 : Foo t++Now, d5 can be solved! d5 := d0++Result+   d1 := dfunData2 d2 d3+   d2 := dfunSat d4+   d3 := d01+   d4 := dfunFoo2 d5+   d5 := d0+-}++{- *********************************************************************+*                                                                      *+                InertCans: the canonical inerts+*                                                                      *+*                                                                      *+********************************************************************* -}++{- Note [Tracking Given equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify+Note [Unification preconditions], we can't unify+   alpha[2] ~ Int+under a level-4 implication if there are any Given equalities+bound by the implications at level 3 of 4.  To that end, the+InertCans tracks++  inert_given_eq_lvl :: TcLevel+     -- The TcLevel of the innermost implication that has a Given+     -- equality of the sort that make a unification variable untouchable+     -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).++We update inert_given_eq_lvl whenever we add a Given to the+inert set, in updateGivenEqs.++Then a unification variable alpha[n] is untouchable iff+    n < inert_given_eq_lvl+that is, if the unification variable was born outside an+enclosing Given equality.++Exactly which constraints should trigger (UNTOUCHABLE), and hence+should update inert_given_eq_lvl?++* We do /not/ need to worry about let-bound skolems, such ast+     forall[2] a. a ~ [b] => blah+  See Note [Let-bound skolems]++* Consider an implication+      forall[2]. beta[1] => alpha[1] ~ Int+  where beta is a unification variable that has already been unified+  to () in an outer scope.  Then alpha[1] is perfectly touchable and+  we can unify alpha := Int. So when deciding whether the givens contain+  an equality, we should canonicalise first, rather than just looking at+  the /original/ givens (#8644).++ * However, we must take account of *potential* equalities. Consider the+   same example again, but this time we have /not/ yet unified beta:+      forall[2] beta[1] => ...blah...++   Because beta might turn into an equality, updateGivenEqs conservatively+   treats it as a potential equality, and updates inert_give_eq_lvl++ * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z?++   That Given cannot affect the Wanted, because the Given is entirely+   *local*: it mentions only skolems bound in the very same+   implication. Such equalities need not make alpha untouchable. (Test+   case typecheck/should_compile/LocalGivenEqs has a real-life+   motivating example, with some detailed commentary.)+   Hence the 'mentionsOuterVar' test in updateGivenEqs.++   However, solely to support better error messages+   (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track+   these "local" equalities in the boolean inert_given_eqs field.+   This field is used only to set the ic_given_eqs field to LocalGivenEqs;+   see the function getHasGivenEqs.++   Here is a simpler case that triggers this behaviour:++     data T where+       MkT :: F a ~ G b => a -> b -> T++     f (MkT _ _) = True++   Because of this behaviour around local equality givens, we can infer the+   type of f. This is typecheck/should_compile/LocalGivenEqs2.++ * We need not look at the equality relation involved (nominal vs+   representational), because representational equalities can still+   imply nominal ones. For example, if (G a ~R G b) and G's argument's+   role is nominal, then we can deduce a ~N b.++Note [Let-bound skolems]+~~~~~~~~~~~~~~~~~~~~~~~~+If   * the inert set contains a canonical Given CEqCan (a ~ ty)+and  * 'a' is a skolem bound in this very implication,++then:+a) The Given is pretty much a let-binding, like+      f :: (a ~ b->c) => a -> a+   Here the equality constraint is like saying+      let a = b->c in ...+   It is not adding any new, local equality  information,+   and hence can be ignored by has_given_eqs++b) 'a' will have been completely substituted out in the inert set,+   so we can safely discard it.++For an example, see #9211.++See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure+that the right variable is on the left of the equality when both are+tyvars.++You might wonder whether the skolem really needs to be bound "in the+very same implication" as the equuality constraint.+Consider this (c.f. #15009):++  data S a where+    MkS :: (a ~ Int) => S a++  g :: forall a. S a -> a -> blah+  g x y = let h = \z. ( z :: Int+                      , case x of+                           MkS -> [y,z])+          in ...++From the type signature for `g`, we get `y::a` .  Then when we+encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the+body of the lambda we'll get++  [W] alpha[1] ~ Int                             -- From z::Int+  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]++Now, unify alpha := a.  Now we are stuck with an unsolved alpha~Int!+So we must treat alpha as untouchable under the forall[2] implication.++Note [Detailed InertCans Invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The InertCans represents a collection of constraints with the following properties:++  * All canonical++  * No two dictionaries with the same head+  * No two CIrreds with the same type++  * Family equations inert wrt top-level family axioms++  * Dictionaries have no matching top-level instance++  * Given family or dictionary constraints don't mention touchable+    unification variables++  * Non-CEqCan constraints are fully rewritten with respect+    to the CEqCan equalities (modulo eqCanRewrite of course;+    eg a wanted cannot rewrite a given)++  * CEqCan equalities: see Note [inert_eqs: the inert equalities]+    Also see documentation in Constraint.Ct for a list of invariants++Note [inert_eqs: the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Definition [Can-rewrite relation]+A "can-rewrite" relation between flavours, written f1 >= f2, is a+binary relation with the following properties++  (R1) >= is transitive+  (R2) If f1 >= f, and f2 >= f,+       then either f1 >= f2 or f2 >= f1+  (See Note [Why R2?].)++Lemma (L0). If f1 >= f then f1 >= f1+Proof.      By property (R2), with f1=f2++Definition [Generalised substitution]+A "generalised substitution" S is a set of triples (lhs -f-> t), where+  lhs is a type variable or an exactly-saturated type family application+    (that is, lhs is a CanEqLHS)+  t is a type+  f is a flavour+such that+  (WF1) if (lhs1 -f1-> t1) in S+           (lhs2 -f2-> t2) in S+        then (f1 >= f2) implies that lhs1 does not appear within lhs2+  (WF2) if (lhs -f-> t) is in S, then t /= lhs++Definition [Applying a generalised substitution]+If S is a generalised substitution+   S(f,t0) = t,  if (t0 -fs-> t) in S, and fs >= f+           = apply S to components of t0, otherwise+See also Note [Flavours with roles].++Theorem: S(f,t0) is well defined as a function.+Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S,+               and  f1 >= f and f2 >= f+       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)++Notation: repeated application.+  S^0(f,t)     = t+  S^(n+1)(f,t) = S(f, S^n(t))++Definition: terminating generalised substitution+A generalised substitution S is *terminating* iff++  (IG1) there is an n such that+        for every f,t, S^n(f,t) = S^(n+1)(f,t)++By (IG1) we define S*(f,t) to be the result of exahaustively+applying S(f,_) to t.++-----------------------------------------------------------------------------+Our main invariant:+   the CEqCans in inert_eqs should be a terminating generalised substitution+-----------------------------------------------------------------------------++Note that termination is not the same as idempotence.  To apply S to a+type, you may have to apply it recursively.  But termination does+guarantee that this recursive use will terminate.++Note [Why R2?]+~~~~~~~~~~~~~~+R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >=+f1. If we do not have R2, we will easily fall into a loop.++To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our+inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And+yet, we have a hard time noticing an occurs-check problem when building S, as+the two equalities cannot rewrite one another.++R2 actually restricts our ability to accept user-written programs. See+Note [Deriveds do rewrite Deriveds] in GHC.Tc.Types.Constraint for an example.++Note [Rewritable]+~~~~~~~~~~~~~~~~~+This Note defines what it means for a type variable or type family application+(that is, a CanEqLHS) to be rewritable in a type. This definition is used+by the anyRewritableXXX family of functions and is meant to model the actual+behaviour in GHC.Tc.Solver.Rewrite.++Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the+lhs tree appears as a subtree within t without traversing any of the following+components of t:+  * coercions (whether they appear in casts CastTy or as arguments CoercionTy)+  * kinds of variable occurrences+The check for rewritability *does* look in kinds of the bound variable of a+ForAllTy.++Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised+substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f+for all f.++The reason for this definition is that the rewriter does not rewrite in coercions+or variables' kinds. In turn, the rewriter does not need to rewrite there because+those places are never used for controlling the behaviour of the solver: these+places are not used in matching instances or in decomposing equalities.++There is one exception to the claim that non-rewritable parts of the tree do+not affect the solver: we sometimes do an occurs-check to decide e.g. how to+orient an equality. (See the comments on+GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a+variable in a kind or coercion just might influence the solver. Here is an+example:++  type family Const x y where+    Const x y = x++  AxConst :: forall x y. Const x y ~# x++  alpha :: Const Type Nat+  [W] alpha ~ Int |> (sym (AxConst Type alpha) ;;+                      AxConst Type alpha ;;+                      sym (AxConst Type Nat))++The cast is clearly ludicrous (it ties together a cast and its symmetric version),+but we can't quite rule it out. (See (EQ1) from+Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need+the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha+from unifying with the RHS. I (Richard E) don't have an example of where this+problem can arise from a Haskell program, but we don't have an air-tight argument+for why the definition of *rewritable* given here is correct.++Taking roles into account: we must consider a rewrite at a given role. That is,+a rewrite arises from some equality, and that equality has a role associated+with it. As we traverse a type, we track what role we are allowed to rewrite with.++For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in+Maybe b but not in F b, where F is a type function. This role-aware logic is+present in both the anyRewritableXXX functions and in the rewriter.+See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType.++Note [Extending the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Main Theorem [Stability under extension]+   Suppose we have a "work item"+       lhs -fw-> t+   and a terminating generalised substitution S,+   THEN the extended substitution T = S+(lhs -fw-> t)+        is a terminating generalised substitution+   PROVIDED+      (T1) S(fw,lhs) = lhs   -- LHS of work-item is a fixpoint of S(fw,_)+      (T2) S(fw,t)   = t     -- RHS of work-item is a fixpoint of S(fw,_)+      (T3) lhs not in t      -- No occurs check in the work item+          -- If lhs is a type family application, we require only that+          -- lhs is not *rewritable* in t. See Note [Rewritable] and+          -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.++      AND, for every (lhs1 -fs-> s) in S:+           (K0) not (fw >= fs)+                Reason: suppose we kick out (lhs1 -fs-> s),+                        and add (lhs -fw-> t) to the inert set.+                        The latter can't rewrite the former,+                        so the kick-out achieved nothing++              -- From here, we can assume fw >= fs+           OR (K4) lhs1 is a tyvar AND fs >= fw++           OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable].+                     Reason: if fw >= fs, WF1 says we can't have both+                             lhs0 -fw-> t  and  F lhs0 -fs-> s++                AND (K2): guarantees termination of the new substitution+                    {  (K2a) not (fs >= fs)+                    OR (K2b) lhs not in s }++                AND (K3) See Note [K3: completeness of solving]+                    { (K3a) If the role of fs is nominal: s /= lhs+                      (K3b) If the role of fs is representational:+                            s is not of form (lhs t1 .. tn) } }+++Conditions (T1-T3) are established by the canonicaliser+Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable++The idea is that+* T1 and T2 are guaranteed by exhaustively rewriting the work-item+  with S(fw,_).++* T3 is guaranteed by an occurs-check on the work item.+  This is done during canonicalisation, in canEqOK and checkTypeEq; invariant+  (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.++* (K1-3) are the "kick-out" criteria.  (As stated, they are really the+  "keep" criteria.) If the current inert S contains a triple that does+  not satisfy (K1-3), then we remove it from S by "kicking it out",+  and re-processing it.++* Note that kicking out is a Bad Thing, because it means we have to+  re-process a constraint.  The less we kick out, the better.+  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed+  this but haven't done the empirical study to check.++* Assume we have  G>=G, G>=W and that's all.  Then, when performing+  a unification we add a new given  a -G-> ty.  But doing so does NOT require+  us to kick out an inert wanted that mentions a, because of (K2a).  This+  is a common case, hence good not to kick out. See also (K2a) below.++* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing+  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything+         and so K0 holds.  Intuitively, since fw can't rewrite anything (Lemma (L0)),+         adding it cannot cause any loops+  This is a common case, because Wanteds cannot rewrite Wanteds.+  It's used to avoid even looking for constraint to kick out.++* Lemma (L1): The conditions of the Main Theorem imply that there is no+              (lhs -fs-> t) in S, s.t.  (fs >= fw).+  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),+  S(fw,lhs)=lhs.  But since fs>=fw, S(fw,lhs) = t, hence t=lhs.  But now we+  have (lhs -fs-> lhs) in S, which contradicts (WF2).++* The extended substitution satisfies (WF1) and (WF2)+  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).+  - (T3) guarantees (WF2).++* (K2) and (K4) are about termination.  Intuitively, any infinite chain S^0(f,t),+  S^1(f,t), S^2(f,t).... must pass through the new work item infinitely+  often, since the substitution without the work item is terminating; and must+  pass through at least one of the triples in S infinitely often.++  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f)+    (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t).+    It is always safe to extend S with such a triple.++    (NB: we could strengten K1) in this way too, but see K3.++  - (K2b): if lhs not in s, we have no further opportunity to apply the+    work item++  - (K4): See Note [K4]++* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then+  if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s.+  Proof. K4 holds; thus, we keep.++Key lemma to make it watertight.+  Under the conditions of the Main Theorem,+  forall f st fw >= f, a is not in S^k(f,t), for any k++Also, consider roles more carefully. See Note [Flavours with roles]++Note [K4]+~~~~~~~~~+K4 is a "keep" condition of Note [Extending the inert equalities].+Here is the scenario:++* We are considering adding (lhs -fw-> t) to the inert set S.+* S already has (lhs1 -fs-> s).+* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t.+  See Note [Rewritable]. These are (T1), (T2), and (T3).+* We further know fw >= fs. (If not, then we short-circuit via (K0).)++K4 says that we may keep lhs1 -fs-> s in S if:+  lhs1 is a tyvar AND fs >= fw++Why K4 guarantees termination:+  * If fs >= fw, we know a is not rewritable in t, because of (T2).+  * We further know lhs /= a, because of (T1).+  * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions+    for a use of a -fs-> s (precisely because t does not mention a), and hence,+    the extended substitution (with lhs -fw-> t in it) is a terminating+    generalised substitution.++Recall that the termination generalised substitution includes only mappings that+pass an occurs check. This is (T3). At one point, we worried that the+argument here would fail if s mentioned a, but (T3) rules out this possibility.+Put another way: the terminating generalised substitution considers only the inert_eqs,+not other parts of the inert set (such as the irreds).++Can we liberalise K4? No.++Why we cannot drop the (fs >= fw) condition:+  * Suppose not (fs >= fw). It might be the case that t mentions a, and this+    can cause a loop. Example:++      Work:  [G] b ~ a+      Inert: [D] a ~ b++    (where G >= G, G >= D, and D >= D)+    If we don't kick out the inert, then we get a loop on e.g. [D] a ~ Int.++  * Note that the above example is different if the inert is a Given G, because+    (T1) won't hold.++Why we cannot drop the tyvar condition:+  * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2).+  * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s?+    Yes! This can happen if t appears within tys.++    Here is an example:++      Work:  [G] a ~ Int+      Inert: [G] F Int ~ F a++    Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand+    side. The key reason why K2b works in the tyvar case is that tyvars are atomic:+    if the right-hand side of an equality does not mention a variable a, then it+    cannot allow an equality with an LHS of a to fire. This is not the case for+    type family applications.++Bottom line: K4 can keep only inerts with tyvars on the left. Put differently,+K4 will never prevent an inert with a type family on the left from being kicked+out.++Consequence: We never kick out a Given/Nominal equality with a tyvar on the left.+This is Lemma (L3) of Note [Extending the inert equalities]. It is good because+it means we can effectively model the mutable filling of metavariables with+Given/Nominal equalities. That is: it should be the case that we could rewrite+our solver never to fill in a metavariable; instead, it would "solve" a wanted+like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting.+We would want the solver to behave the same whether it uses metavariables or+Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out,+just like we never unfill a metavariable. Nice.++Getting this wrong (that is, allowing K4 to apply to situations with the type+family on the left) led to #19042. (At that point, K4 was known as K2b.)++Originally, this condition was part of K2, but #17672 suggests it should be+a top-level K condition.++Note [K3: completeness of solving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(K3) is not necessary for the extended substitution+to be terminating.  In fact K1 could be made stronger by saying+   ... then (not (fw >= fs) or not (fs >= fs))+But it's not enough for S to be terminating; we also want completeness.+That is, we want to be able to solve all soluble wanted equalities.+Suppose we have++   work-item   b -G-> a+   inert-item  a -W-> b++Assuming (G >= W) but not (W >= W), this fulfills all the conditions,+so we could extend the inerts, thus:++   inert-items   b -G-> a+                 a -W-> b++But if we kicked-out the inert item, we'd get++   work-item     a -W-> b+   inert-item    b -G-> a++Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.+So we add one more clause to the kick-out criteria++Another way to understand (K3) is that we treat an inert item+        a -f-> b+in the same way as+        b -f-> a+So if we kick out one, we should kick out the other.  The orientation+is somewhat accidental.++When considering roles, we also need the second clause (K3b). Consider++  work-item    c -G/N-> a+  inert-item   a -W/R-> b c++The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.+But we don't kick out the inert item because not (W/R >= W/R).  So we just+add the work item. But then, consider if we hit the following:++  work-item    b -G/N-> Id+  inert-items  a -W/R-> b c+               c -G/N-> a+where+  newtype Id x = Id x++For similar reasons, if we only had (K3a), we wouldn't kick the+representational inert out. And then, we'd miss solving the inert, which+now reduced to reflexivity.++The solution here is to kick out representational inerts whenever the+lhs of a work item is "exposed", where exposed means being at the+head of the top-level application chain (lhs t1 .. tn).  See+is_can_eq_lhs_head. This is encoded in (K3b).++Beware: if we make this test succeed too often, we kick out too much,+and the solver might loop.  Consider (#14363)+  work item:   [G] a ~R f b+  inert item:  [G] b ~R f a+In GHC 8.2 the completeness tests more aggressive, and kicked out+the inert item; but no rewriting happened and there was an infinite+loop.  All we need is to have the tyvar at the head.++Note [Flavours with roles]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The system described in Note [inert_eqs: the inert equalities]+discusses an abstract+set of flavours. In GHC, flavours have two components: the flavour proper,+taken from {Wanted, Derived, Given} and the equality relation (often called+role), taken from {NomEq, ReprEq}.+When substituting w.r.t. the inert set,+as described in Note [inert_eqs: the inert equalities],+we must be careful to respect all components of a flavour.+For example, if we have++  inert set: a -G/R-> Int+             b -G/R-> Bool++  type role T nominal representational++and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT+T Int Bool. The reason is that T's first parameter has a nominal role, and+thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of+substitution means that the proof in Note [inert_eqs: the inert equalities] may+need to be revisited, but we don't think that the end conclusion is wrong.+-}++data InertCans   -- See Note [Detailed InertCans Invariants] for more+  = IC { inert_eqs :: InertEqs+              -- See Note [inert_eqs: the inert equalities]+              -- All CEqCans with a TyVarLHS; index is the LHS tyvar+              -- Domain = skolems and untouchables; a touchable would be unified++       , inert_funeqs :: FunEqMap EqualCtList+              -- All CEqCans with a TyFamLHS; index is the whole family head type.+              -- LHS is fully rewritten (modulo eqCanRewrite constraints)+              --     wrt inert_eqs+              -- Can include all flavours, [G], [W], [WD], [D]++       , inert_dicts :: DictMap Ct+              -- Dictionaries only+              -- All fully rewritten (modulo flavour constraints)+              --     wrt inert_eqs++       , inert_insts :: [QCInst]++       , inert_safehask :: DictMap Ct+              -- Failed dictionary resolution due to Safe Haskell overlapping+              -- instances restriction. We keep this separate from inert_dicts+              -- as it doesn't cause compilation failure, just safe inference+              -- failure.+              --+              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]+              -- in GHC.Tc.Solver++       , inert_irreds :: Cts+              -- Irreducible predicates that cannot be made canonical,+              --     and which don't interact with others (e.g.  (c a))+              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])++       , inert_given_eq_lvl :: TcLevel+              -- The TcLevel of the innermost implication that has a Given+              -- equality of the sort that make a unification variable untouchable+              -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).+              -- See Note [Tracking Given equalities]++       , inert_given_eqs :: Bool+              -- True <=> The inert Givens *at this level* (tcl_tclvl)+              --          could includes at least one equality /other than/ a+              --          let-bound skolem equality.+              -- Reason: report these givens when reporting a failed equality+              -- See Note [Tracking Given equalities]+       }++type InertEqs    = DTyVarEnv EqualCtList++instance Outputable InertCans where+  ppr (IC { inert_eqs = eqs+          , inert_funeqs = funeqs, inert_dicts = dicts+          , inert_safehask = safehask, inert_irreds = irreds+          , inert_given_eq_lvl = ge_lvl+          , inert_given_eqs = given_eqs+          , inert_insts = insts })++    = braces $ vcat+      [ ppUnless (isEmptyDVarEnv eqs) $+        text "Equalities:"+          <+> pprCts (foldDVarEnv folder emptyCts eqs)+      , ppUnless (isEmptyTcAppMap funeqs) $+        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)+      , ppUnless (isEmptyTcAppMap dicts) $+        text "Dictionaries =" <+> pprCts (dictsToBag dicts)+      , ppUnless (isEmptyTcAppMap safehask) $+        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)+      , ppUnless (isEmptyCts irreds) $+        text "Irreds =" <+> pprCts irreds+      , ppUnless (null insts) $+        text "Given instances =" <+> vcat (map ppr insts)+      , text "Innermost given equalities =" <+> ppr ge_lvl+      , text "Given eqs at this level =" <+> ppr given_eqs+      ]+    where+      folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest++{- *********************************************************************+*                                                                      *+                   Inert equalities+*                                                                      *+********************************************************************* -}++addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs+addTyEq old_eqs tv ct+  = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct)+  where+    add_eq old_eqs _ = addToEqualCtList ct old_eqs++addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct+            -> FunEqMap EqualCtList+addCanFunEq old_eqs fun_tc fun_args ct+  = alterTcApp old_eqs fun_tc fun_args upd+  where+    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list+    upd Nothing                  = Just $ unitEqualCtList ct++foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b+foldTyEqs k eqs z+  = foldDVarEnv (\(EqualCtList cts) z -> foldr k z cts) z eqs++findTyEqs :: InertCans -> TyVar -> [Ct]+findTyEqs icans tv = maybe [] id (fmap @Maybe equalCtListToList $+                                  lookupDVarEnv (inert_eqs icans) tv)++delEq :: InertCans -> CanEqLHS -> TcType -> InertCans+delEq ic lhs rhs = case lhs of+    TyVarLHS tv+      -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }+    TyFamLHS tf args+      -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }+  where+    isThisOne :: Ct -> Bool+    isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1+    isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)++    upd :: Maybe EqualCtList -> Maybe EqualCtList+    upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list+    upd Nothing           = Nothing++findEq :: InertCans -> CanEqLHS -> [Ct]+findEq icans (TyVarLHS tv) = findTyEqs icans tv+findEq icans (TyFamLHS fun_tc fun_args)+  = maybe [] id (fmap @Maybe equalCtListToList $+                 findFunEq (inert_funeqs icans) fun_tc fun_args)++{- *********************************************************************+*                                                                      *+                Adding to and removing from the inert set+*                                                                      *+*                                                                      *+********************************************************************* -}++addInertItem :: TcLevel -> InertCans -> Ct -> InertCans+addInertItem tc_lvl+             ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })+             item@(CEqCan { cc_lhs = lhs })+  = updateGivenEqs tc_lvl item $+    case lhs of+       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item }+       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv item }++addInertItem tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})+  = updateGivenEqs tc_lvl item $   -- An Irred might turn out to be an+                                 -- equality, so we play safe+    ics { inert_irreds = irreds `snocBag` item }++addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })+  = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item }++addInertItem _ _ item+  = pprPanic "upd_inert set: can't happen! Inserting " $+    ppr item   -- Can't be CNonCanonical because they only land in inert_irreds++updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans+-- Set the inert_given_eq_level to the current level (tclvl)+-- if the constraint is a given equality that should prevent+-- filling in an outer unification variable.+-- See Note [Tracking Given equalities]+updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })+  | not (isGivenCt ct) = inerts+  | not_equality ct    = inerts -- See Note [Let-bound skolems]+  | otherwise          = inerts { inert_given_eq_lvl = ge_lvl'+                                , inert_given_eqs    = True }+  where+    ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct)+              -- Includes things like (c a), which *might* be an equality+            = tclvl+            | otherwise+            = ge_lvl++    not_equality :: Ct -> Bool+    -- True <=> definitely not an equality of any kind+    --          except for a let-bound skolem, which doesn't count+    --          See Note [Let-bound skolems]+    -- NB: no need to spot the boxed CDictCan (a ~ b) because its+    --     superclass (a ~# b) will be a CEqCan+    not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv)+    not_equality (CDictCan {})                     = True+    not_equality _                                 = False++kickOutRewritableLHS :: CtFlavourRole  -- Flavour/role of the equality that+                                       -- is being added to the inert set+                     -> CanEqLHS       -- The new equality is lhs ~ ty+                     -> InertCans+                     -> (WorkList, InertCans)+-- See Note [kickOutRewritable]+kickOutRewritableLHS new_fr new_lhs+                     ics@(IC { inert_eqs      = tv_eqs+                             , inert_dicts    = dictmap+                             , inert_funeqs   = funeqmap+                             , inert_irreds   = irreds+                             , inert_insts    = old_insts })+  | not (new_fr `eqMayRewriteFR` new_fr)+  = (emptyWorkList, ics)+        -- If new_fr can't rewrite itself, it can't rewrite+        -- anything else, so no need to kick out anything.+        -- (This is a common case: wanteds can't rewrite wanteds)+        -- Lemma (L2) in Note [Extending the inert equalities]++  | otherwise+  = (kicked_out, inert_cans_in)+  where+    -- inert_safehask stays unchanged; is that right?+    inert_cans_in = ics { inert_eqs      = tv_eqs_in+                        , inert_dicts    = dicts_in+                        , inert_funeqs   = feqs_in+                        , inert_irreds   = irs_in+                        , inert_insts    = insts_in }++    kicked_out :: WorkList+    -- NB: use extendWorkList to ensure that kicked-out equalities get priority+    -- See Note [Prioritise equalities] (Kick-out).+    -- The irreds may include non-canonical (hetero-kinded) equality+    -- constraints, which perhaps may have become soluble after new_lhs+    -- is substituted; ditto the dictionaries, which may include (a~b)+    -- or (a~~b) constraints.+    kicked_out = foldr extendWorkListCt+                          (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })+                          ((dicts_out `andCts` irs_out)+                            `extendCtsList` insts_out)++    (tv_eqs_out, tv_eqs_in) = foldDVarEnv (kick_out_eqs extend_tv_eqs)+                                          ([], emptyDVarEnv) tv_eqs+    (feqs_out,   feqs_in)   = foldFunEqs  (kick_out_eqs extend_fun_eqs)+                                          funeqmap ([], emptyFunEqs)+    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap+    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds+      -- Kick out even insolubles: See Note [Rewrite insolubles]+      -- Of course we must kick out irreducibles like (c a), in case+      -- we can rewrite 'c' to something more useful++    -- Kick-out for inert instances+    -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical+    insts_out :: [Ct]+    insts_in  :: [QCInst]+    (insts_out, insts_in)+       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens+       = partitionWith kick_out_qci old_insts+       | otherwise+       = ([], old_insts)+    kick_out_qci qci+      | let ev = qci_ev qci+      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))+      = Left (mkNonCanonical ev)+      | otherwise+      = Right qci++    (_, new_role) = new_fr++    fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool+    fr_tv_can_rewrite_ty new_tv role ty+      = anyRewritableTyVar True role can_rewrite ty+                  -- True: ignore casts and coercions+      where+        can_rewrite :: EqRel -> TyVar -> Bool+        can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv++    fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool+    fr_tf_can_rewrite_ty new_tf new_tf_args role ty+      = anyRewritableTyFamApp role can_rewrite ty+      where+        can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool+        can_rewrite old_role old_tf old_tf_args+          = new_role `eqCanRewrite` old_role &&+            tcEqTyConApps new_tf new_tf_args old_tf old_tf_args+              -- it's possible for old_tf_args to have too many. This is fine;+              -- we'll only check what we need to.++    {-# INLINE fr_can_rewrite_ty #-}   -- perform the check here only once+    fr_can_rewrite_ty :: EqRel -> Type -> Bool+    fr_can_rewrite_ty = case new_lhs of+      TyVarLHS new_tv             -> fr_tv_can_rewrite_ty new_tv+      TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args++    fr_may_rewrite :: CtFlavourRole -> Bool+    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs+        -- Can the new item rewrite the inert item?++    {-# INLINE kick_out_ct #-}   -- perform case on new_lhs here only once+    kick_out_ct :: Ct -> Bool+    -- Kick it out if the new CEqCan can rewrite the inert one+    -- See Note [kickOutRewritable]+    kick_out_ct = case new_lhs of+      TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in+                                fr_may_rewrite fs+                             && fr_tv_can_rewrite_ty new_tv role (ctPred ct)+      TyFamLHS new_tf new_tf_args+        -> \ct -> let fs@(_, role) = ctFlavourRole ct in+                  fr_may_rewrite fs+               && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)++    extend_tv_eqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs+    extend_tv_eqs eqs (TyVarLHS tv) cts = extendDVarEnv eqs tv cts+    extend_tv_eqs eqs other _cts = pprPanic "extend_tv_eqs" (ppr eqs $$ ppr other)++    extend_fun_eqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList+                   -> FunEqMap EqualCtList+    extend_fun_eqs eqs (TyFamLHS fam_tc fam_args) cts+      = insertTcApp eqs fam_tc fam_args cts+    extend_fun_eqs eqs other _cts = pprPanic "extend_fun_eqs" (ppr eqs $$ ppr other)++    kick_out_eqs :: (container -> CanEqLHS -> EqualCtList -> container)+                 -> EqualCtList -> ([Ct], container)+                 -> ([Ct], container)+    kick_out_eqs extend eqs (acc_out, acc_in)+      = (eqs_out `chkAppend` acc_out, case listToEqualCtList eqs_in of+            Nothing -> acc_in+            Just eqs_in_ecl@(EqualCtList (eq1 :| _))+                    -> extend acc_in (cc_lhs eq1) eqs_in_ecl)+      where+        (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs)++    -- Implements criteria K1-K3 in Note [Extending the inert equalities]+    kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty+                        , cc_ev = ev, cc_eq_rel = eq_rel })+      | not (fr_may_rewrite fs)+      = False  -- (K0) Keep it in the inert set if the new thing can't rewrite it++      -- Below here (fr_may_rewrite fs) is True++      | TyVarLHS _ <- lhs+      , fs `eqMayRewriteFR` new_fr+      = False  -- (K4) Keep it in the inert set if the LHS is a tyvar and+               -- it can rewrite the work item. See Note [K4]++      | fr_can_rewrite_ty eq_rel (canEqLHSType lhs)+      = True   -- (K1)+         -- The above check redundantly checks the role & flavour,+         -- but it's very convenient++      | kick_out_for_inertness    = True   -- (K2)+      | kick_out_for_completeness = True   -- (K3)+      | otherwise                 = False++      where+        fs = (ctEvFlavour ev, eq_rel)+        kick_out_for_inertness+          =    (fs `eqMayRewriteFR` fs)           -- (K2a)+            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2b)++        kick_out_for_completeness  -- (K3) and Note [K3: completeness of solving]+          = case eq_rel of+              NomEq  -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)+              ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty    -- (K3b)++    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)++    is_can_eq_lhs_head (TyVarLHS tv) = go+      where+        go (Rep.TyVarTy tv')   = tv == tv'+        go (Rep.AppTy fun _)   = go fun+        go (Rep.CastTy ty _)   = go ty+        go (Rep.TyConApp {})   = False+        go (Rep.LitTy {})      = False+        go (Rep.ForAllTy {})   = False+        go (Rep.FunTy {})      = False+        go (Rep.CoercionTy {}) = False+    is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go+      where+        go (Rep.TyVarTy {})       = False+        go (Rep.AppTy {})         = False  -- no TyConApp to the left of an AppTy+        go (Rep.CastTy ty _)      = go ty+        go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args+        go (Rep.LitTy {})         = False+        go (Rep.ForAllTy {})      = False+        go (Rep.FunTy {})         = False+        go (Rep.CoercionTy {})    = False++{- Note [kickOutRewritable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [inert_eqs: the inert equalities].++When we add a new inert equality (lhs ~N ty) to the inert set,+we must kick out any inert items that could be rewritten by the+new equality, to maintain the inert-set invariants.++  - We want to kick out an existing inert constraint if+    a) the new constraint can rewrite the inert one+    b) 'lhs' is free in the inert constraint (so that it *will*)+       rewrite it if we kick it out.++    For (b) we use anyRewritableCanLHS, which examines the types /and+    kinds/ that are directly visible in the type. Hence+    we will have exposed all the rewriting we care about to make the+    most precise kinds visible for matching classes etc. No need to+    kick out constraints that mention type variables whose kinds+    contain this LHS!++  - A Derived equality can kick out [D] constraints in inert_eqs,+    inert_dicts, inert_irreds etc.++  - We don't kick out constraints from inert_solved_dicts, and+    inert_solved_funeqs optimistically. But when we lookup we have to+    take the substitution into account++NB: we could in principle avoid kick-out:+  a) When unifying a meta-tyvar from an outer level, because+     then the entire implication will be iterated; see+     Note [The Unification Level Flag] in GHC.Tc.Solver.Monad.++  b) For Givens, after a unification.  By (GivenInv) in GHC.Tc.Utils.TcType+     Note [TcLevel invariants], a Given can't include a meta-tyvar from+     its own level, so it falls under (a).  Of course, we must still+     kick out Givens when adding a new non-unification Given.++But kicking out more vigorously may lead to earlier unification and fewer+iterations, so we don't take advantage of these possibilities.++Note [Rewrite insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an insoluble alpha ~ [alpha], which is insoluble+because an occurs check.  And then we unify alpha := [Int].  Then we+really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can+be decomposed.  Otherwise we end up with a "Can't match [Int] ~+[[Int]]" which is true, but a bit confusing because the outer type+constructors match.++Hence:+ * In the main simplifier loops in GHC.Tc.Solver (solveWanteds,+   simpl_loop), we feed the insolubles in solveSimpleWanteds,+   so that they get rewritten (albeit not solved).++ * We kick insolubles out of the inert set, if they can be+   rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)++ * We rewrite those insolubles in GHC.Tc.Solver.Canonical.+   See Note [Make sure that insolubles are fully rewritten]+   in GHC.Tc.Solver.Canonical.+-}++{- *********************************************************************+*                                                                      *+                 Queries+*                                                                      *+*                                                                      *+********************************************************************* -}++mentionsOuterVar :: TcLevel -> CtEvidence -> Bool+mentionsOuterVar tclvl ev+  = anyFreeVarsOfType (isOuterTyVar tclvl) $+    ctEvPred ev++isOuterTyVar :: TcLevel -> TyCoVar -> Bool+-- True of a type variable that comes from a+-- shallower level than the ambient level (tclvl)+isOuterTyVar tclvl tv+  | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $+                 tclvl `strictlyDeeperThan` tcTyVarLevel tv+    -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from+    -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't+    -- be a touchable meta tyvar.   If this wasn't true, you might worry that,+    -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby+    -- becomes "outer" even though its level numbers says it isn't.+  | otherwise  = False  -- Coercion variables; doesn't much matter++-- | Returns Given constraints that might,+-- potentially, match the given pred. This is used when checking to see if a+-- Given might overlap with an instance. See Note [Instance and Given overlap]+-- in "GHC.Tc.Solver.Interact"+matchableGivens :: CtLoc -> PredType -> InertSet -> Cts+matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans })+  = filterBag matchable_given all_relevant_givens+  where+    -- just look in class constraints and irreds. matchableGivens does get called+    -- for ~R constraints, but we don't need to look through equalities, because+    -- canonical equalities are used for rewriting. We'll only get caught by+    -- non-canonical -- that is, irreducible -- equalities.+    all_relevant_givens :: Cts+    all_relevant_givens+      | Just (clas, _) <- getClassPredTys_maybe pred_w+      = findDictsByClass (inert_dicts inert_cans) clas+        `unionBags` inert_irreds inert_cans+      | otherwise+      = inert_irreds inert_cans++    matchable_given :: Ct -> Bool+    matchable_given ct+      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct+      = mightEqualLater inerts pred_g loc_g pred_w loc_w++      | otherwise+      = False++mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool+-- See Note [What might equal later?]+-- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact+mightEqualLater (IS { inert_cycle_breakers = cbvs })+                given_pred given_loc wanted_pred wanted_loc+  | prohibitedSuperClassSolve given_loc wanted_loc+  = False++  | otherwise+  = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of+      SurelyApart              -> False  -- types that are surely apart do not equal later+      MaybeApart MARInfinite _ -> False  -- see Example 7 in the Note.+      _                        -> True++  where+    in_scope  = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred]++    -- NB: flatten both at the same time, so that we can share mappings+    -- from type family applications to variables, and also to guarantee+    -- 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]++    bind_fun :: BindFun+    bind_fun tv rhs_ty+      | isMetaTyVar tv+      , can_unify tv (metaTyVarInfo tv) rhs_ty+         -- this checks for CycleBreakerTvs and TyVarTvs; forgetting+         -- the latter was #19106.+      = BindMe++         -- See Examples 4, 5, and 6 from the Note+      | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv+      , anyFreeVarsOfTypes mentions_meta_ty_var fam_args+      = BindMe++      | otherwise+      = Apart++    -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars+    -- (as they can be unified)+    -- and also for CycleBreakerTvs that mentions meta-tyvars+    mentions_meta_ty_var :: TyVar -> Bool+    mentions_meta_ty_var tv+      | isMetaTyVar tv+      = case metaTyVarInfo tv of+          -- See Examples 8 and 9 in the Note+          CycleBreakerTv+            | Just tyfam_app <- lookup tv cbvs+            -> anyFreeVarsOfType mentions_meta_ty_var tyfam_app+            | otherwise+            -> pprPanic "mightEqualLater finds an unbound cbv" (ppr tv $$ ppr cbvs)+          _ -> True+      | otherwise+      = False++    -- like canSolveByUnification, but allows cbv variables to unify+    can_unify :: TcTyVar -> MetaInfo -> Type -> Bool+    can_unify _lhs_tv TyVarTv rhs_ty  -- see Example 3 from the Note+      | Just rhs_tv <- tcGetTyVar_maybe rhs_ty+      = case tcTyVarDetails rhs_tv of+          MetaTv { mtv_info = TyVarTv } -> True+          MetaTv {}                     -> False  -- could unify with anything+          SkolemTv {}                   -> True+          RuntimeUnk                    -> True+      | otherwise  -- not a var on the RHS+      = False+    can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv++prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool+-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+prohibitedSuperClassSolve from_loc solve_loc+  | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc+  , ScOrigin wanted_size <- ctLocOrigin solve_loc+  = given_size >= wanted_size+  | otherwise+  = False
compiler/GHC/Tc/Solver/Interact.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} @@ -8,8 +8,6 @@      solveSimpleWanteds,  -- Solves Cts   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Types.Basic ( SwapFlag(..),                          infinity, IntWithInf, intGtLimit )@@ -33,12 +31,15 @@ import GHC.Tc.Types.Evidence import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Tc.Types import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo )+import GHC.Tc.Solver.Types+import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Data.Bag import GHC.Utils.Monad ( concatMapM, foldlM )@@ -1065,7 +1066,7 @@  -- Enabled by the -fsolve-constant-dicts flag    = do { ev_binds_var <- getTcEvBindsVar-       ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )+       ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $                      getTcEvBindsMap ev_binds_var        ; solved_dicts <- getSolvedDicts @@ -1290,7 +1291,7 @@ -- See Note [FunDep and implicit parameter reactions] -- Precondition: isImprovable work_ev improveLocalFunEqs work_ev inerts fam_tc args rhs-  = ASSERT( isImprovable work_ev )+  = assert (isImprovable work_ev) $     unless (null improvement_eqns) $     do { traceTcS "interactFunEq improvements: " $                    vcat [ text "Eqns:" <+> ppr improvement_eqns@@ -2390,7 +2391,7 @@  And less obviously to: -* Tuple classes.  For reasons described in GHC.Tc.Solver.Monad+* Tuple classes.  For reasons described in GHC.Tc.Solver.Types   Note [Tuples hiding implicit parameters], we may have a constraint      [W] (?x::Int, C a)   with an exactly-matching Given constraint.  We must decompose this@@ -2471,8 +2472,8 @@       = (match:matches, unif)        | otherwise-      = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred)-               , ppr qci $$ ppr pred )+      = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred))+                  (ppr qci $$ ppr pred)             -- ASSERT: unification relies on the             -- quantified variables being fresh         (matches, unif || this_unif)
compiler/GHC/Tc/Solver/Monad.hs view
@@ -3,3989 +3,2124 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}---- | Type definitions for the constraint solver-module GHC.Tc.Solver.Monad (--    -- The work list-    WorkList(..), isEmptyWorkList, emptyWorkList,-    extendWorkListNonEq, extendWorkListCt,-    extendWorkListCts, extendWorkListEq,-    appendWorkList,-    selectNextWorkItem,-    workListSize,-    getWorkList, updWorkListTcS, pushLevelNoWorkList,--    -- The TcS monad-    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, runTcSInerts,-    failTcS, warnTcS, addErrTcS, wrapTcS,-    runTcSEqualities,-    nestTcS, nestImplicTcS, setEvBindsTcS,-    emitImplicationTcS, emitTvImplicationTcS,--    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,-    matchGlobalInst, TcM.ClsInstResult(..),--    QCInst(..),--    -- Tracing etc-    panicTcS, traceTcS,-    traceFireTcS, bumpStepCountTcS, csTraceTcS,-    wrapErrTcS, wrapWarnTcS,-    resetUnificationFlag, setUnificationFlag,--    -- Evidence creation and transformation-    MaybeNew(..), freshGoals, isFresh, getEvExpr,--    newTcEvBinds, newNoTcEvBinds,-    newWantedEq, newWantedEq_SI, emitNewWantedEq,-    newWanted, newWanted_SI, newWantedEvVar,-    newWantedNC, newWantedEvVarNC,-    newDerivedNC,-    newBoundEvVarId,-    unifyTyVar, reportUnifications,-    setEvBind, setWantedEq,-    setWantedEvTerm, setEvBindIfWanted,-    newEvVar, newGivenEvVar, newGivenEvVars,-    emitNewDeriveds, emitNewDerivedEq,-    checkReductionDepth,-    getSolvedDicts, setSolvedDicts,--    getInstEnvs, getFamInstEnvs,                -- Getting the environments-    getTopEnv, getGblEnv, getLclEnv,-    getTcEvBindsVar, getTcLevel,-    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,-    tcLookupClass, tcLookupId,--    -- Inerts-    InertSet(..), InertCans(..), emptyInert,-    updInertTcS, updInertCans, updInertDicts, updInertIrreds,-    getHasGivenEqs, setInertCans,-    getInertEqs, getInertCans, getInertGivens,-    getInertInsols, getInnermostGivenEqLevel,-    getTcSInerts, setTcSInerts,-    matchableGivens, prohibitedSuperClassSolve, mightEqualLater,-    getUnsolvedInerts,-    removeInertCts, getPendingGivenScs,-    addInertCan, insertFunEq, addInertForAll,-    emitWorkNC, emitWork,-    isImprovable,--    -- The Model-    kickOutAfterUnification,--    -- Inert Safe Haskell safe-overlap failures-    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,-    getSafeOverlapFailures,--    -- Inert CDictCans-    DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,-    addDictsByClass, delDict, foldDicts, filterDicts, findDict,--    -- Inert CEqCans-    EqualCtList(..), findTyEqs, foldTyEqs,-    findEq,--    -- Inert solved dictionaries-    addSolvedDict, lookupSolvedDict,--    -- Irreds-    foldIrreds,--    -- The family application cache-    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,-    pprKicked,--    -- Inert function equalities-    findFunEq, findFunEqsByTyCon,--    instDFunType,                              -- Instantiation--    -- MetaTyVars-    newFlexiTcSTy, instFlexi, instFlexiX,-    cloneMetaTyVar,-    tcInstSkolTyVarsX,--    TcLevel,-    isFilledMetaTyVar_maybe, isFilledMetaTyVar,-    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,-    zonkTyCoVarsAndFVList,-    zonkSimples, zonkWC,-    zonkTyCoVarKind,--    -- References-    newTcRef, readTcRef, writeTcRef, updTcRef,--    -- Misc-    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,-    matchFam, matchFamTcM,-    checkWellStagedDFun,-    pprEq,                                   -- Smaller utils, re-exported from TcM-                                             -- TODO (DV): these are only really used in the-                                             -- instance matcher in GHC.Tc.Solver. I am wondering-                                             -- if the whole instance matcher simply belongs-                                             -- here--    breakTyVarCycle, rewriterView-) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Driver.Env--import qualified GHC.Tc.Utils.Instantiate as TcM-import GHC.Core.InstEnv-import GHC.Tc.Instance.Family as FamInst-import GHC.Core.FamInstEnv--import qualified GHC.Tc.Utils.Monad    as TcM-import qualified GHC.Tc.Utils.TcMType  as TcM-import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )-import qualified GHC.Tc.Utils.Env      as TcM-       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )-import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )-import GHC.Tc.Utils.TcType-import GHC.Driver.Session-import GHC.Core.Type-import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally-import GHC.Core.Coercion-import GHC.Core.Unify--import GHC.Tc.Types.Evidence-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Tc.Errors   ( solverDepthErrorTcS )--import GHC.Types.Name-import GHC.Types.TyThing-import GHC.Unit.Module ( HasModule, getModule )-import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )-import qualified GHC.Rename.Env as TcM-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Logger-import GHC.Data.Bag as Bag-import GHC.Types.Unique.Supply-import GHC.Utils.Misc-import GHC.Tc.Types-import GHC.Tc.Types.Origin-import GHC.Tc.Types.Constraint-import GHC.Core.Predicate--import GHC.Types.Unique.Set-import GHC.Core.TyCon.Env-import GHC.Data.Maybe--import GHC.Core.Map.Type-import GHC.Data.TrieMap--import Control.Monad-import GHC.Utils.Monad-import Data.IORef-import GHC.Exts (oneShot)-import Data.List ( partition, mapAccumL )-import Data.List.NonEmpty ( NonEmpty(..), cons, toList, nonEmpty )-import qualified Data.List.NonEmpty as NE-import Control.Arrow ( first )--#if defined(DEBUG)-import GHC.Data.Graph.Directed-#endif--{--************************************************************************-*                                                                      *-*                            Worklists                                *-*  Canonical and non-canonical constraints that the simplifier has to  *-*  work on. Including their simplification depths.                     *-*                                                                      *-*                                                                      *-************************************************************************--Note [WorkList priorities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-A WorkList contains canonical and non-canonical items (of all flavours).-Notice that each Ct now has a simplification depth. We may-consider using this depth for prioritization as well in the future.--As a simple form of priority queue, our worklist separates out--* equalities (wl_eqs); see Note [Prioritise equalities]-* all the rest (wl_rest)--Note [Prioritise equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very important to process equalities /first/:--* (Efficiency)  The general reason to do so is that if we process a-  class constraint first, we may end up putting it into the inert set-  and then kicking it out later.  That's extra work compared to just-  doing the equality first.--* (Avoiding fundep iteration) As #14723 showed, it's possible to-  get non-termination if we-      - Emit the Derived fundep equalities for a class constraint,-        generating some fresh unification variables.-      - That leads to some unification-      - Which kicks out the class constraint-      - Which isn't solved (because there are still some more Derived-        equalities in the work-list), but generates yet more fundeps-  Solution: prioritise derived equalities over class constraints--* (Class equalities) We need to prioritise equalities even if they-  are hidden inside a class constraint;-  see Note [Prioritise class equalities]--* (Kick-out) We want to apply this priority scheme to kicked-out-  constraints too (see the call to extendWorkListCt in kick_out_rewritable-  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become-  homo-kinded when kicked out, and hence we want to prioritise it.--* (Derived equalities) Originally we tried to postpone processing-  Derived equalities, in the hope that we might never need to deal-  with them at all; but in fact we must process Derived equalities-  eagerly, partly for the (Efficiency) reason, and more importantly-  for (Avoiding fundep iteration).--Note [Prioritise class equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We prioritise equalities in the solver (see selectWorkItem). But class-constraints like (a ~ b) and (a ~~ b) are actually equalities too;-see Note [The equality types story] in GHC.Builtin.Types.Prim.--Failing to prioritise these is inefficient (more kick-outs etc).-But, worse, it can prevent us spotting a "recursive knot" among-Wanted constraints.  See comment:10 of #12734 for a worked-out-example.--So we arrange to put these particular class constraints in the wl_eqs.--  NB: since we do not currently apply the substitution to the-  inert_solved_dicts, the knot-tying still seems a bit fragile.-  But this makes it better.---}---- See Note [WorkList priorities]-data WorkList-  = WL { wl_eqs     :: [Ct]  -- CEqCan, CDictCan, CIrredCan-                             -- Given, Wanted, and Derived-                       -- Contains both equality constraints and their-                       -- class-level variants (a~b) and (a~~b);-                       -- See Note [Prioritise equalities]-                       -- See Note [Prioritise class equalities]--       , wl_rest    :: [Ct]--       , wl_implics :: Bag Implication  -- See Note [Residual implications]-    }--appendWorkList :: WorkList -> WorkList -> WorkList-appendWorkList-    (WL { wl_eqs = eqs1, wl_rest = rest1-        , wl_implics = implics1 })-    (WL { wl_eqs = eqs2, wl_rest = rest2-        , wl_implics = implics2 })-   = WL { wl_eqs     = eqs1     ++ eqs2-        , wl_rest    = rest1    ++ rest2-        , wl_implics = implics1 `unionBags`   implics2 }--workListSize :: WorkList -> Int-workListSize (WL { wl_eqs = eqs, wl_rest = rest })-  = length eqs + length rest--extendWorkListEq :: Ct -> WorkList -> WorkList-extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }--extendWorkListNonEq :: Ct -> WorkList -> WorkList--- Extension by non equality-extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }--extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList-extendWorkListDeriveds evs wl-  = extendWorkListCts (map mkNonCanonical evs) wl--extendWorkListImplic :: Implication -> WorkList -> WorkList-extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }--extendWorkListCt :: Ct -> WorkList -> WorkList--- Agnostic-extendWorkListCt ct wl- = case classifyPredType (ctPred ct) of-     EqPred {}-       -> extendWorkListEq ct wl--     ClassPred cls _  -- See Note [Prioritise class equalities]-       |  isEqPredClass cls-       -> extendWorkListEq ct wl--     _ -> extendWorkListNonEq ct wl--extendWorkListCts :: [Ct] -> WorkList -> WorkList--- Agnostic-extendWorkListCts cts wl = foldr extendWorkListCt wl cts--isEmptyWorkList :: WorkList -> Bool-isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })-  = null eqs && null rest && isEmptyBag implics--emptyWorkList :: WorkList-emptyWorkList = WL { wl_eqs  = [], wl_rest = [], wl_implics = emptyBag }--selectWorkItem :: WorkList -> Maybe (Ct, WorkList)--- See Note [Prioritise equalities]-selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest })-  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })-  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })-  | otherwise      = Nothing--getWorkList :: TcS WorkList-getWorkList = do { wl_var <- getTcSWorkListRef-                 ; wrapTcS (TcM.readTcRef wl_var) }--selectNextWorkItem :: TcS (Maybe Ct)--- Pick which work item to do next--- See Note [Prioritise equalities]-selectNextWorkItem-  = do { wl_var <- getTcSWorkListRef-       ; wl <- readTcRef wl_var-       ; case selectWorkItem wl of {-           Nothing -> return Nothing ;-           Just (ct, new_wl) ->-    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)-         -- This is done by GHC.Tc.Solver.Interact.chooseInstance-       ; writeTcRef wl_var new_wl-       ; return (Just ct) } } }---- Pretty printing-instance Outputable WorkList where-  ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })-   = text "WL" <+> (braces $-     vcat [ ppUnless (null eqs) $-            text "Eqs =" <+> vcat (map ppr eqs)-          , ppUnless (null rest) $-            text "Non-eqs =" <+> vcat (map ppr rest)-          , ppUnless (isEmptyBag implics) $-            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))-                       (text "(Implics omitted)")-          ])---{- *********************************************************************-*                                                                      *-                InertSet: the inert set-*                                                                      *-*                                                                      *-********************************************************************* -}--data InertSet-  = IS { inert_cans :: InertCans-              -- Canonical Given, Wanted, Derived-              -- Sometimes called "the inert set"--       , inert_cycle_breakers :: [(TcTyVar, TcType)]-              -- a list of CycleBreakerTv / original family applications-              -- used to undo the cycle-breaking needed to handle-              -- Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical--       , inert_famapp_cache :: FunEqMap (TcCoercion, TcType)-              -- Just a hash-cons cache for use when reducing family applications-              -- only-              ---              -- If    F tys :-> (co, rhs, flav),-              -- then  co :: rhs ~N F tys-              -- all evidence is from instances or Givens; no coercion holes here-              -- (We have no way of "kicking out" from the cache, so putting-              --  wanteds here means we can end up solving a Wanted with itself. Bad)--       , inert_solved_dicts   :: DictMap CtEvidence-              -- All Wanteds, of form ev :: C t1 .. tn-              -- See Note [Solved dictionaries]-              -- and Note [Do not add superclasses of solved dictionaries]-       }--instance Outputable InertSet where-  ppr (IS { inert_cans = ics-          , inert_solved_dicts = solved_dicts })-      = vcat [ ppr ics-             , ppUnless (null dicts) $-               text "Solved dicts =" <+> vcat (map ppr dicts) ]-         where-           dicts = bagToList (dictsToBag solved_dicts)--emptyInertCans :: InertCans-emptyInertCans-  = IC { inert_eqs          = emptyDVarEnv-       , inert_given_eq_lvl = topTcLevel-       , inert_given_eqs    = False-       , inert_dicts        = emptyDicts-       , inert_safehask     = emptyDicts-       , inert_funeqs       = emptyFunEqs-       , inert_insts        = []-       , inert_irreds       = emptyCts }--emptyInert :: InertSet-emptyInert-  = IS { inert_cans           = emptyInertCans-       , inert_cycle_breakers = []-       , inert_famapp_cache   = emptyFunEqs-       , inert_solved_dicts   = emptyDictMap }---{- Note [Solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we apply a top-level instance declaration, we add the "solved"-dictionary to the inert_solved_dicts.  In general, we use it to avoid-creating a new EvVar when we have a new goal that we have solved in-the past.--But in particular, we can use it to create *recursive* dictionaries.-The simplest, degenerate case is-    instance C [a] => C [a] where ...-If we have-    [W] d1 :: C [x]-then we can apply the instance to get-    d1 = $dfCList d-    [W] d2 :: C [x]-Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.-    d1 = $dfCList d-    d2 = d1--See Note [Example of recursive dictionaries]--VERY IMPORTANT INVARIANT:-- (Solved Dictionary Invariant)-    Every member of the inert_solved_dicts is the result-    of applying an instance declaration that "takes a step"--    An instance "takes a step" if it has the form-        dfunDList d1 d2 = MkD (...) (...) (...)-    That is, the dfun is lazy in its arguments, and guarantees to-    immediately return a dictionary constructor.  NB: all dictionary-    data constructors are lazy in their arguments.--    This property is crucial to ensure that all dictionaries are-    non-bottom, which in turn ensures that the whole "recursive-    dictionary" idea works at all, even if we get something like-        rec { d = dfunDList d dx }-    See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.-- Reason:-   - All instances, except two exceptions listed below, "take a step"-     in the above sense--   - Exception 1: local quantified constraints have no such guarantee;-     indeed, adding a "solved dictionary" when appling a quantified-     constraint led to the ability to define unsafeCoerce-     in #17267.--   - Exception 2: the magic built-in instance for (~) has no-     such guarantee.  It behaves as if we had-         class    (a ~# b) => (a ~ b) where {}-         instance (a ~# b) => (a ~ b) where {}-     The "dfun" for the instance is strict in the coercion.-     Anyway there's no point in recording a "solved dict" for-     (t1 ~ t2); it's not going to allow a recursive dictionary-     to be constructed.  Ditto (~~) and Coercible.--THEREFORE we only add a "solved dictionary"-  - when applying an instance declaration-  - subject to Exceptions 1 and 2 above--In implementation terms-  - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary,-    conditional on the kind of instance--  - It is only called when applying an instance decl,-    in GHC.Tc.Solver.Interact.doTopReactDict--  - ClsInst.InstanceWhat says what kind of instance was-    used to solve the constraint.  In particular-      * LocalInstance identifies quantified constraints-      * BuiltinEqInstance identifies the strange built-in-        instances for equality.--  - ClsInst.instanceReturnsDictCon says which kind of-    instance guarantees to return a dictionary constructor--Other notes about solved dictionaries--* See also Note [Do not add superclasses of solved dictionaries]--* The inert_solved_dicts field is not rewritten by equalities,-  so it may get out of date.--* The inert_solved_dicts are all Wanteds, never givens--* We only cache dictionaries from top-level instances, not from-  local quantified constraints.  Reason: if we cached the latter-  we'd need to purge the cache when bringing new quantified-  constraints into scope, because quantified constraints "shadow"-  top-level instances.--Note [Do not add superclasses of solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Every member of inert_solved_dicts is the result of applying a-dictionary function, NOT of applying superclass selection to anything.-Consider--        class Ord a => C a where-        instance Ord [a] => C [a] where ...--Suppose we are trying to solve-  [G] d1 : Ord a-  [W] d2 : C [a]--Then we'll use the instance decl to give--  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3-  [W] d3 : Ord [a]--We must not add d4 : Ord [a] to the 'solved' set (by taking the-superclass of d2), otherwise we'll use it to solve d3, without ever-using d1, which would be a catastrophe.--Solution: when extending the solved dictionaries, do not add superclasses.-That's why each element of the inert_solved_dicts is the result of applying-a dictionary function.--Note [Example of recursive dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Example 1--    data D r = ZeroD | SuccD (r (D r));--    instance (Eq (r (D r))) => Eq (D r) where-        ZeroD     == ZeroD     = True-        (SuccD a) == (SuccD b) = a == b-        _         == _         = False;--    equalDC :: D [] -> D [] -> Bool;-    equalDC = (==);--We need to prove (Eq (D [])). Here's how we go:--   [W] d1 : Eq (D [])-By instance decl of Eq (D r):-   [W] d2 : Eq [D []]      where   d1 = dfEqD d2-By instance decl of Eq [a]:-   [W] d3 : Eq (D [])      where   d2 = dfEqList d3-                                   d1 = dfEqD d2-Now this wanted can interact with our "solved" d1 to get:-    d3 = d1---- Example 2:-This code arises in the context of "Scrap Your Boilerplate with Class"--    class Sat a-    class Data ctx a-    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1-    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2--    class Data Maybe a => Foo a--    instance Foo t => Sat (Maybe t)                             -- dfunSat--    instance Data Maybe a => Foo a                              -- dfunFoo1-    instance Foo a        => Foo [a]                            -- dfunFoo2-    instance                 Foo [Char]                         -- dfunFoo3--Consider generating the superclasses of the instance declaration-         instance Foo a => Foo [a]--So our problem is this-    [G] d0 : Foo t-    [W] d1 : Data Maybe [t]   -- Desired superclass--We may add the given in the inert set, along with its superclasses-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  WorkList-    [W] d1 : Data Maybe [t]--Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-  WorkList:-    [W] d2 : Sat (Maybe [t])-    [W] d3 : Data Maybe t--Now, we may simplify d2 using dfunSat; d2 := dfunSat d4-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList:-    [W] d3 : Data Maybe t-    [W] d4 : Foo [t]--Now, we can just solve d3 from d01; d3 := d01-  Inert-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList-    [W] d4 : Foo [t]--Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5-  Inert-    [G] d0  : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-        d4 : Foo [t]-  WorkList:-    [W] d5 : Foo t--Now, d5 can be solved! d5 := d0--Result-   d1 := dfunData2 d2 d3-   d2 := dfunSat d4-   d3 := d01-   d4 := dfunFoo2 d5-   d5 := d0--}--{- *********************************************************************-*                                                                      *-                InertCans: the canonical inerts-*                                                                      *-*                                                                      *-********************************************************************* -}--data InertCans   -- See Note [Detailed InertCans Invariants] for more-  = IC { inert_eqs :: InertEqs-              -- See Note [inert_eqs: the inert equalities]-              -- All CEqCans with a TyVarLHS; index is the LHS tyvar-              -- Domain = skolems and untouchables; a touchable would be unified--       , inert_funeqs :: FunEqMap EqualCtList-              -- All CEqCans with a TyFamLHS; index is the whole family head type.-              -- LHS is fully rewritten (modulo eqCanRewrite constraints)-              --     wrt inert_eqs-              -- Can include all flavours, [G], [W], [WD], [D]--       , inert_dicts :: DictMap Ct-              -- Dictionaries only-              -- All fully rewritten (modulo flavour constraints)-              --     wrt inert_eqs--       , inert_insts :: [QCInst]--       , inert_safehask :: DictMap Ct-              -- Failed dictionary resolution due to Safe Haskell overlapping-              -- instances restriction. We keep this separate from inert_dicts-              -- as it doesn't cause compilation failure, just safe inference-              -- failure.-              ---              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]-              -- in "GHC.Tc.Solver"--       , inert_irreds :: Cts-              -- Irreducible predicates that cannot be made canonical,-              --     and which don't interact with others (e.g.  (c a))-              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])--       , inert_given_eq_lvl :: TcLevel-              -- The TcLevel of the innermost implication that has a Given-              -- equality of the sort that make a unification variable untouchable-              -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).-              -- See Note [Tracking Given equalities] below--       , inert_given_eqs :: Bool-              -- True <=> The inert Givens *at this level* (tcl_tclvl)-              --          could includes at least one equality /other than/ a-              --          let-bound skolem equality.-              -- Reason: report these givens when reporting a failed equality-              -- See Note [Tracking Given equalities]-       }--type InertEqs    = DTyVarEnv EqualCtList--newtype EqualCtList = EqualCtList (NonEmpty Ct)-  deriving newtype Outputable-  -- See Note [EqualCtList invariants]--unitEqualCtList :: Ct -> EqualCtList-unitEqualCtList ct = EqualCtList (ct :| [])--addToEqualCtList :: Ct -> EqualCtList -> EqualCtList--- NB: This function maintains the "derived-before-wanted" invariant of EqualCtList,--- but not the others. See Note [EqualCtList invariants]-addToEqualCtList ct (EqualCtList old_eqs)-  | isWantedCt ct-  , eq1 :| eqs <- old_eqs-  = EqualCtList (eq1 :| ct : eqs)-  | otherwise-  = EqualCtList (ct `cons` old_eqs)--filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList-filterEqualCtList pred (EqualCtList cts)-  = fmap EqualCtList (nonEmpty $ NE.filter pred cts)--equalCtListToList :: EqualCtList -> [Ct]-equalCtListToList (EqualCtList cts) = toList cts--listToEqualCtList :: [Ct] -> Maybe EqualCtList--- NB: This does not maintain invariants other than having the EqualCtList be--- non-empty-listToEqualCtList cts = EqualCtList <$> nonEmpty cts--{- Note [Tracking Given equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify-Note [Unification preconditions], we can't unify-   alpha[2] ~ Int-under a level-4 implication if there are any Given equalities-bound by the implications at level 3 of 4.  To that end, the-InertCans tracks--  inert_given_eq_lvl :: TcLevel-     -- The TcLevel of the innermost implication that has a Given-     -- equality of the sort that make a unification variable untouchable-     -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).--We update inert_given_eq_lvl whenever we add a Given to the-inert set, in updateGivenEqs.--Then a unification variable alpha[n] is untouchable iff-    n < inert_given_eq_lvl-that is, if the unification variable was born outside an-enclosing Given equality.--Exactly which constraints should trigger (UNTOUCHABLE), and hence-should update inert_given_eq_lvl?--* We do /not/ need to worry about let-bound skolems, such ast-     forall[2] a. a ~ [b] => blah-  See Note [Let-bound skolems]--* Consider an implication-      forall[2]. beta[1] => alpha[1] ~ Int-  where beta is a unification variable that has already been unified-  to () in an outer scope.  Then alpha[1] is perfectly touchable and-  we can unify alpha := Int. So when deciding whether the givens contain-  an equality, we should canonicalise first, rather than just looking at-  the /original/ givens (#8644).-- * However, we must take account of *potential* equalities. Consider the-   same example again, but this time we have /not/ yet unified beta:-      forall[2] beta[1] => ...blah...--   Because beta might turn into an equality, updateGivenEqs conservatively-   treats it as a potential equality, and updates inert_give_eq_lvl-- * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z?--   That Given cannot affect the Wanted, because the Given is entirely-   *local*: it mentions only skolems bound in the very same-   implication. Such equalities need not make alpha untouchable. (Test-   case typecheck/should_compile/LocalGivenEqs has a real-life-   motivating example, with some detailed commentary.)-   Hence the 'mentionsOuterVar' test in updateGivenEqs.--   However, solely to support better error messages-   (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track-   these "local" equalities in the boolean inert_given_eqs field.-   This field is used only to set the ic_given_eqs field to LocalGivenEqs;-   see the function getHasGivenEqs.--   Here is a simpler case that triggers this behaviour:--     data T where-       MkT :: F a ~ G b => a -> b -> T--     f (MkT _ _) = True--   Because of this behaviour around local equality givens, we can infer the-   type of f. This is typecheck/should_compile/LocalGivenEqs2.-- * We need not look at the equality relation involved (nominal vs-   representational), because representational equalities can still-   imply nominal ones. For example, if (G a ~R G b) and G's argument's-   role is nominal, then we can deduce a ~N b.--Note [Let-bound skolems]-~~~~~~~~~~~~~~~~~~~~~~~~-If   * the inert set contains a canonical Given CEqCan (a ~ ty)-and  * 'a' is a skolem bound in this very implication,--then:-a) The Given is pretty much a let-binding, like-      f :: (a ~ b->c) => a -> a-   Here the equality constraint is like saying-      let a = b->c in ...-   It is not adding any new, local equality  information,-   and hence can be ignored by has_given_eqs--b) 'a' will have been completely substituted out in the inert set,-   so we can safely discard it.--For an example, see #9211.--See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure-that the right variable is on the left of the equality when both are-tyvars.--You might wonder whether the skolem really needs to be bound "in the-very same implication" as the equuality constraint.-Consider this (c.f. #15009):--  data S a where-    MkS :: (a ~ Int) => S a--  g :: forall a. S a -> a -> blah-  g x y = let h = \z. ( z :: Int-                      , case x of-                           MkS -> [y,z])-          in ...--From the type signature for `g`, we get `y::a` .  Then when we-encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the-body of the lambda we'll get--  [W] alpha[1] ~ Int                             -- From z::Int-  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]--Now, unify alpha := a.  Now we are stuck with an unsolved alpha~Int!-So we must treat alpha as untouchable under the forall[2] implication.--Note [Detailed InertCans Invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The InertCans represents a collection of constraints with the following properties:--  * All canonical--  * No two dictionaries with the same head-  * No two CIrreds with the same type--  * Family equations inert wrt top-level family axioms--  * Dictionaries have no matching top-level instance--  * Given family or dictionary constraints don't mention touchable-    unification variables--  * Non-CEqCan constraints are fully rewritten with respect-    to the CEqCan equalities (modulo eqCanRewrite of course;-    eg a wanted cannot rewrite a given)--  * CEqCan equalities: see Note [inert_eqs: the inert equalities]-    Also see documentation in Constraint.Ct for a list of invariants--Note [EqualCtList invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    * All are equalities-    * All these equalities have the same LHS-    * The list is never empty-    * No element of the list can rewrite any other-    * Derived before Wanted--From the fourth invariant it follows that the list is-   - A single [G], or-   - Zero or one [D] or [WD], followed by any number of [W]--The Wanteds can't rewrite anything which is why we put them last--Note [inert_eqs: the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Definition [Can-rewrite relation]-A "can-rewrite" relation between flavours, written f1 >= f2, is a-binary relation with the following properties--  (R1) >= is transitive-  (R2) If f1 >= f, and f2 >= f,-       then either f1 >= f2 or f2 >= f1-  (See Note [Why R2?].)--Lemma (L0). If f1 >= f then f1 >= f1-Proof.      By property (R2), with f1=f2--Definition [Generalised substitution]-A "generalised substitution" S is a set of triples (lhs -f-> t), where-  lhs is a type variable or an exactly-saturated type family application-    (that is, lhs is a CanEqLHS)-  t is a type-  f is a flavour-such that-  (WF1) if (lhs1 -f1-> t1) in S-           (lhs2 -f2-> t2) in S-        then (f1 >= f2) implies that lhs1 does not appear within lhs2-  (WF2) if (lhs -f-> t) is in S, then t /= lhs--Definition [Applying a generalised substitution]-If S is a generalised substitution-   S(f,t0) = t,  if (t0 -fs-> t) in S, and fs >= f-           = apply S to components of t0, otherwise-See also Note [Flavours with roles].--Theorem: S(f,t0) is well defined as a function.-Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S,-               and  f1 >= f and f2 >= f-       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)--Notation: repeated application.-  S^0(f,t)     = t-  S^(n+1)(f,t) = S(f, S^n(t))--Definition: terminating generalised substitution-A generalised substitution S is *terminating* iff--  (IG1) there is an n such that-        for every f,t, S^n(f,t) = S^(n+1)(f,t)--By (IG1) we define S*(f,t) to be the result of exahaustively-applying S(f,_) to t.--------------------------------------------------------------------------------Our main invariant:-   the CEqCans in inert_eqs should be a terminating generalised substitution--------------------------------------------------------------------------------Note that termination is not the same as idempotence.  To apply S to a-type, you may have to apply it recursively.  But termination does-guarantee that this recursive use will terminate.--Note [Why R2?]-~~~~~~~~~~~~~~-R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >=-f1. If we do not have R2, we will easily fall into a loop.--To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our-inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And-yet, we have a hard time noticing an occurs-check problem when building S, as-the two equalities cannot rewrite one another.--R2 actually restricts our ability to accept user-written programs. See Note-[Deriveds do rewrite Deriveds] in GHC.Tc.Types.Constraint for an example.--Note [Rewritable]-~~~~~~~~~~~~~~~~~-This Note defines what it means for a type variable or type family application-(that is, a CanEqLHS) to be rewritable in a type. This definition is used-by the anyRewritableXXX family of functions and is meant to model the actual-behaviour in GHC.Tc.Solver.Rewrite.--Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the-lhs tree appears as a subtree within t without traversing any of the following-components of t:-  * coercions (whether they appear in casts CastTy or as arguments CoercionTy)-  * kinds of variable occurrences-The check for rewritability *does* look in kinds of the bound variable of a-ForAllTy.--Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised-substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f-for all f.--The reason for this definition is that the rewriter does not rewrite in coercions-or variables' kinds. In turn, the rewriter does not need to rewrite there because-those places are never used for controlling the behaviour of the solver: these-places are not used in matching instances or in decomposing equalities.--There is one exception to the claim that non-rewritable parts of the tree do-not affect the solver: we sometimes do an occurs-check to decide e.g. how to-orient an equality. (See the comments on-GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a-variable in a kind or coercion just might influence the solver. Here is an-example:--  type family Const x y where-    Const x y = x--  AxConst :: forall x y. Const x y ~# x--  alpha :: Const Type Nat-  [W] alpha ~ Int |> (sym (AxConst Type alpha) ;;-                      AxConst Type alpha ;;-                      sym (AxConst Type Nat))--The cast is clearly ludicrous (it ties together a cast and its symmetric version),-but we can't quite rule it out. (See (EQ1) from-Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need-the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha-from unifying with the RHS. I (Richard E) don't have an example of where this-problem can arise from a Haskell program, but we don't have an air-tight argument-for why the definition of *rewritable* given here is correct.--Taking roles into account: we must consider a rewrite at a given role. That is,-a rewrite arises from some equality, and that equality has a role associated-with it. As we traverse a type, we track what role we are allowed to rewrite with.--For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in-Maybe b but not in F b, where F is a type function. This role-aware logic is-present in both the anyRewritableXXX functions and in the rewriter.-See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType.--Note [Extending the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Main Theorem [Stability under extension]-   Suppose we have a "work item"-       lhs -fw-> t-   and a terminating generalised substitution S,-   THEN the extended substitution T = S+(lhs -fw-> t)-        is a terminating generalised substitution-   PROVIDED-      (T1) S(fw,lhs) = lhs   -- LHS of work-item is a fixpoint of S(fw,_)-      (T2) S(fw,t)   = t     -- RHS of work-item is a fixpoint of S(fw,_)-      (T3) lhs not in t      -- No occurs check in the work item-          -- If lhs is a type family application, we require only that-          -- lhs is not *rewritable* in t. See Note [Rewritable] and-          -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.--      AND, for every (lhs1 -fs-> s) in S:-           (K0) not (fw >= fs)-                Reason: suppose we kick out (lhs1 -fs-> s),-                        and add (lhs -fw-> t) to the inert set.-                        The latter can't rewrite the former,-                        so the kick-out achieved nothing--              -- From here, we can assume fw >= fs-           OR (K4) lhs1 is a tyvar AND fs >= fw--           OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable].-                     Reason: if fw >= fs, WF1 says we can't have both-                             lhs0 -fw-> t  and  F lhs0 -fs-> s--                AND (K2): guarantees termination of the new substitution-                    {  (K2a) not (fs >= fs)-                    OR (K2b) lhs not in s }--                AND (K3) See Note [K3: completeness of solving]-                    { (K3a) If the role of fs is nominal: s /= lhs-                      (K3b) If the role of fs is representational:-                            s is not of form (lhs t1 .. tn) } }---Conditions (T1-T3) are established by the canonicaliser-Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable--The idea is that-* T1 and T2 are guaranteed by exhaustively rewriting the work-item-  with S(fw,_).--* T3 is guaranteed by an occurs-check on the work item.-  This is done during canonicalisation, in canEqOK and checkTypeEq; invariant-  (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.--* (K1-3) are the "kick-out" criteria.  (As stated, they are really the-  "keep" criteria.) If the current inert S contains a triple that does-  not satisfy (K1-3), then we remove it from S by "kicking it out",-  and re-processing it.--* Note that kicking out is a Bad Thing, because it means we have to-  re-process a constraint.  The less we kick out, the better.-  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed-  this but haven't done the empirical study to check.--* Assume we have  G>=G, G>=W and that's all.  Then, when performing-  a unification we add a new given  a -G-> ty.  But doing so does NOT require-  us to kick out an inert wanted that mentions a, because of (K2a).  This-  is a common case, hence good not to kick out. See also (K2a) below.--* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing-  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything-         and so K0 holds.  Intuitively, since fw can't rewrite anything (Lemma (L0)),-         adding it cannot cause any loops-  This is a common case, because Wanteds cannot rewrite Wanteds.-  It's used to avoid even looking for constraint to kick out.--* Lemma (L1): The conditions of the Main Theorem imply that there is no-              (lhs -fs-> t) in S, s.t.  (fs >= fw).-  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),-  S(fw,lhs)=lhs.  But since fs>=fw, S(fw,lhs) = t, hence t=lhs.  But now we-  have (lhs -fs-> lhs) in S, which contradicts (WF2).--* The extended substitution satisfies (WF1) and (WF2)-  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).-  - (T3) guarantees (WF2).--* (K2) and (K4) are about termination.  Intuitively, any infinite chain S^0(f,t),-  S^1(f,t), S^2(f,t).... must pass through the new work item infinitely-  often, since the substitution without the work item is terminating; and must-  pass through at least one of the triples in S infinitely often.--  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f)-    (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t).-    It is always safe to extend S with such a triple.--    (NB: we could strengten K1) in this way too, but see K3.--  - (K2b): if lhs not in s, we have no further opportunity to apply the-    work item--  - (K4): See Note [K4]--* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then-  if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s.-  Proof. K4 holds; thus, we keep.--Key lemma to make it watertight.-  Under the conditions of the Main Theorem,-  forall f st fw >= f, a is not in S^k(f,t), for any k--Also, consider roles more carefully. See Note [Flavours with roles]--Note [K4]-~~~~~~~~~-K4 is a "keep" condition of Note [Extending the inert equalities].-Here is the scenario:--* We are considering adding (lhs -fw-> t) to the inert set S.-* S already has (lhs1 -fs-> s).-* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t.-  See Note [Rewritable]. These are (T1), (T2), and (T3).-* We further know fw >= fs. (If not, then we short-circuit via (K0).)--K4 says that we may keep lhs1 -fs-> s in S if:-  lhs1 is a tyvar AND fs >= fw--Why K4 guarantees termination:-  * If fs >= fw, we know a is not rewritable in t, because of (T2).-  * We further know lhs /= a, because of (T1).-  * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions-    for a use of a -fs-> s (precisely because t does not mention a), and hence,-    the extended substitution (with lhs -fw-> t in it) is a terminating-    generalised substitution.--Recall that the termination generalised substitution includes only mappings that-pass an occurs check. This is (T3). At one point, we worried that the-argument here would fail if s mentioned a, but (T3) rules out this possibility.-Put another way: the terminating generalised substitution considers only the inert_eqs,-not other parts of the inert set (such as the irreds).--Can we liberalise K4? No.--Why we cannot drop the (fs >= fw) condition:-  * Suppose not (fs >= fw). It might be the case that t mentions a, and this-    can cause a loop. Example:--      Work:  [G] b ~ a-      Inert: [D] a ~ b--    (where G >= G, G >= D, and D >= D)-    If we don't kick out the inert, then we get a loop on e.g. [D] a ~ Int.--  * Note that the above example is different if the inert is a Given G, because-    (T1) won't hold.--Why we cannot drop the tyvar condition:-  * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2).-  * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s?-    Yes! This can happen if t appears within tys.--    Here is an example:--      Work:  [G] a ~ Int-      Inert: [G] F Int ~ F a--    Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand-    side. The key reason why K2b works in the tyvar case is that tyvars are atomic:-    if the right-hand side of an equality does not mention a variable a, then it-    cannot allow an equality with an LHS of a to fire. This is not the case for-    type family applications.--Bottom line: K4 can keep only inerts with tyvars on the left. Put differently,-K4 will never prevent an inert with a type family on the left from being kicked-out.--Consequence: We never kick out a Given/Nominal equality with a tyvar on the left.-This is Lemma (L3) of Note [Extending the inert equalities]. It is good because-it means we can effectively model the mutable filling of metavariables with-Given/Nominal equalities. That is: it should be the case that we could rewrite-our solver never to fill in a metavariable; instead, it would "solve" a wanted-like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting.-We would want the solver to behave the same whether it uses metavariables or-Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out,-just like we never unfill a metavariable. Nice.--Getting this wrong (that is, allowing K4 to apply to situations with the type-family on the left) led to #19042. (At that point, K4 was known as K2b.)--Originally, this condition was part of K2, but #17672 suggests it should be-a top-level K condition.--Note [K3: completeness of solving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(K3) is not necessary for the extended substitution-to be terminating.  In fact K1 could be made stronger by saying-   ... then (not (fw >= fs) or not (fs >= fs))-But it's not enough for S to be terminating; we also want completeness.-That is, we want to be able to solve all soluble wanted equalities.-Suppose we have--   work-item   b -G-> a-   inert-item  a -W-> b--Assuming (G >= W) but not (W >= W), this fulfills all the conditions,-so we could extend the inerts, thus:--   inert-items   b -G-> a-                 a -W-> b--But if we kicked-out the inert item, we'd get--   work-item     a -W-> b-   inert-item    b -G-> a--Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.-So we add one more clause to the kick-out criteria--Another way to understand (K3) is that we treat an inert item-        a -f-> b-in the same way as-        b -f-> a-So if we kick out one, we should kick out the other.  The orientation-is somewhat accidental.--When considering roles, we also need the second clause (K3b). Consider--  work-item    c -G/N-> a-  inert-item   a -W/R-> b c--The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.-But we don't kick out the inert item because not (W/R >= W/R).  So we just-add the work item. But then, consider if we hit the following:--  work-item    b -G/N-> Id-  inert-items  a -W/R-> b c-               c -G/N-> a-where-  newtype Id x = Id x--For similar reasons, if we only had (K3a), we wouldn't kick the-representational inert out. And then, we'd miss solving the inert, which-now reduced to reflexivity.--The solution here is to kick out representational inerts whenever the-lhs of a work item is "exposed", where exposed means being at the-head of the top-level application chain (lhs t1 .. tn).  See-is_can_eq_lhs_head. This is encoded in (K3b).--Beware: if we make this test succeed too often, we kick out too much,-and the solver might loop.  Consider (#14363)-  work item:   [G] a ~R f b-  inert item:  [G] b ~R f a-In GHC 8.2 the completeness tests more aggressive, and kicked out-the inert item; but no rewriting happened and there was an infinite-loop.  All we need is to have the tyvar at the head.--Note [Flavours with roles]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The system described in Note [inert_eqs: the inert equalities]-discusses an abstract-set of flavours. In GHC, flavours have two components: the flavour proper,-taken from {Wanted, Derived, Given} and the equality relation (often called-role), taken from {NomEq, ReprEq}.-When substituting w.r.t. the inert set,-as described in Note [inert_eqs: the inert equalities],-we must be careful to respect all components of a flavour.-For example, if we have--  inert set: a -G/R-> Int-             b -G/R-> Bool--  type role T nominal representational--and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT-T Int Bool. The reason is that T's first parameter has a nominal role, and-thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of-substitution means that the proof in Note [The inert equalities] may need-to be revisited, but we don't think that the end conclusion is wrong.--}--instance Outputable InertCans where-  ppr (IC { inert_eqs = eqs-          , inert_funeqs = funeqs, inert_dicts = dicts-          , inert_safehask = safehask, inert_irreds = irreds-          , inert_given_eq_lvl = ge_lvl-          , inert_given_eqs = given_eqs-          , inert_insts = insts })--    = braces $ vcat-      [ ppUnless (isEmptyDVarEnv eqs) $-        text "Equalities:"-          <+> pprCts (foldDVarEnv folder emptyCts eqs)-      , ppUnless (isEmptyTcAppMap funeqs) $-        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)-      , ppUnless (isEmptyTcAppMap dicts) $-        text "Dictionaries =" <+> pprCts (dictsToBag dicts)-      , ppUnless (isEmptyTcAppMap safehask) $-        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)-      , ppUnless (isEmptyCts irreds) $-        text "Irreds =" <+> pprCts irreds-      , ppUnless (null insts) $-        text "Given instances =" <+> vcat (map ppr insts)-      , text "Innermost given equalities =" <+> ppr ge_lvl-      , text "Given eqs at this level =" <+> ppr given_eqs-      ]-    where-      folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest--{- *********************************************************************-*                                                                      *-             Shadow constraints and improvement-*                                                                      *-************************************************************************--Note [The improvement story and derived shadows]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not-rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for-solving.  Here's a classic example (indexed-types/should_fail/T4093a)--    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e--    We get [G] Foo e ~ Maybe e    (CEqCan)-           [W] Foo ee ~ Foo e     (CEqCan)       -- ee is a unification variable-           [W] Foo ee ~ Maybe ee  (CEqCan)--    The first Wanted gets rewritten to--           [W] Foo ee ~ Maybe e--    But now we appear to be stuck, since we don't rewrite Wanteds with-    Wanteds.  This is silly because we can see that ee := e is the-    only solution.--The basic plan is-  * generate Derived constraints that shadow Wanted constraints-  * allow Derived to rewrite Derived-  * in order to cause some unifications to take place-  * that in turn solve the original Wanteds--The ONLY reason for all these Derived equalities is to tell us how to-unify a variable: that is, what Mark Jones calls "improvement".--The same idea is sometimes also called "saturation"; find all the-equalities that must hold in any solution.--Or, equivalently, you can think of the derived shadows as implementing-the "model": a non-idempotent but no-occurs-check substitution,-reflecting *all* *Nominal* equalities (a ~N ty) that are not-immediately soluble by unification.--More specifically, here's how it works (Oct 16):--* Wanted constraints are born as [WD]; this behaves like a-  [W] and a [D] paired together.--* When we are about to add a [WD] to the inert set, if it can-  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],-  putting the latter into the work list (see maybeEmitShadow).--In the example above, we get to the point where we are stuck:-    [WD] Foo ee ~ Foo e-    [WD] Foo ee ~ Maybe ee--But now when [WD] Foo ee ~ Maybe ee is about to be added, we'll-split it into [W] and [D], since the inert [WD] Foo ee ~ Foo e-can rewrite it.  Then:-    work item: [D] Foo ee ~ Maybe ee-    inert:     [W] Foo ee ~ Maybe ee-               [WD] Foo ee ~ Maybe e--See Note [Splitting WD constraints].  Now the work item is rewritten-by the [WD] and we soon get ee := e.--Additional notes:--  * The derived shadow equalities live in inert_eqs, along with-    the Givens and Wanteds; see Note [EqualCtList invariants].--  * We make Derived shadows only for Wanteds, not Givens.  So we-    have only [G], not [GD] and [G] plus splitting.  See-    Note [Add derived shadows only for Wanteds]--  * We also get Derived equalities from functional dependencies-    and type-function injectivity; see calls to unifyDerived.--  * It's worth having [WD] rather than just [W] and [D] because-    * efficiency: silly to process the same thing twice-    * inert_dicts is a finite map keyed by-      the type; it's inconvenient for it to map to TWO constraints--Another example requiring Deriveds is in-Note [Put touchable variables on the left] in GHC.Tc.Solver.Canonical.--Note [Splitting WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We are about to add a [WD] constraint to the inert set; and we-know that the inert set has fully rewritten it.  Should we split-it into [W] and [D], and put the [D] in the work list for further-work?--* CDictCan (C tys):-  Yes if the inert set could rewrite tys to make the class constraint,-  or type family, fire.  That is, yes if the inert_eqs intersects-  with the free vars of tys.  For this test we use-  (anyRewritableTyVar True) which ignores casts and coercions in tys,-  because rewriting the casts or coercions won't make the thing fire-  more often.--* CEqCan (lhs ~ ty): Yes if the inert set could rewrite 'lhs' or 'ty'.-  We need to check both 'lhs' and 'ty' against the inert set:-    - Inert set contains  [D] a ~ ty2-      Then we want to put [D] a ~ ty in the worklist, so we'll-      get [D] ty ~ ty2 with consequent good things--    - Inert set contains [D] b ~ a, where b is in ty.-      We can't just add [WD] a ~ ty[b] to the inert set, because-      that breaks the inert-set invariants.  If we tried to-      canonicalise another [D] constraint mentioning 'a', we'd-      get an infinite loop--  Moreover we must use (anyRewritableTyVar False) for the RHS,-  because even tyvars in the casts and coercions could give-  an infinite loop if we don't expose it--* CIrredCan: Yes if the inert set can rewrite the constraint.-  We used to think splitting irreds was unnecessary, but-  see Note [Splitting Irred WD constraints]--* Others: nothing is gained by splitting.--Note [Splitting Irred WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Splitting Irred constraints can make a difference. Here is the-scenario:--  a[sk] :: F v     -- F is a type family-  beta :: alpha--  work item: [WD] a ~ beta--This is heterogeneous, so we emit a kind equality and make the work item an-inert Irred.--  work item: [D] F v ~ alpha-  inert: [WD] (a |> co) ~ beta (CIrredCan)--Can't make progress on the work item. Add to inert set. This kicks out the-old inert, because a [D] can rewrite a [WD].--  work item: [WD] (a |> co) ~ beta-  inert: [D] F v ~ alpha (CEqCan)--Can't make progress on this work item either (although GHC tries by-decomposing the cast and rewriting... but that doesn't make a difference),-which is still hetero. Emit a new kind equality and add to inert set. But,-critically, we split the Irred.--  work list:-   [D] F v ~ alpha (CEqCan)-   [D] (a |> co) ~ beta (CIrred) -- this one was split off-  inert:-   [W] (a |> co) ~ beta-   [D] F v ~ alpha--We quickly solve the first work item, as it's the same as an inert.--  work item: [D] (a |> co) ~ beta-  inert:-   [W] (a |> co) ~ beta-   [D] F v ~ alpha--We decompose the cast, yielding--  [D] a ~ beta--We then rewrite the kinds. The lhs kind is F v, which flattens to alpha.--  co' :: F v ~ alpha-  [D] (a |> co') ~ beta--Now this equality is homo-kinded. So we swizzle it around to--  [D] beta ~ (a |> co')--and set beta := a |> co', and go home happy.--If we don't split the Irreds, we loop. This is all dangerously subtle.--This is triggered by test case typecheck/should_compile/SplitWD.--Note [Add derived shadows only for Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We only add shadows for Wanted constraints. That is, we have-[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]-constraints.--It does just possibly make sense ot add a derived shadow for a-Given. If we created a Derived shadow of a Given, it could be-rewritten by other Deriveds, and that could, conceivably, lead to a-useful unification.--But (a) I have been unable to come up with an example of this-        happening-    (b) see #12660 for how adding the derived shadows-        of a Given led to an infinite loop.-    (c) It's unlikely that rewriting derived Givens will lead-        to a unification because Givens don't mention touchable-        unification variables--For (b) there may be other ways to solve the loop, but simply-reraining from adding derived shadows of Givens is particularly-simple.  And it's more efficient too!--Still, here's one possible reason for adding derived shadows-for Givens.  Consider-           work-item [G] a ~ [b], inerts has [D] b ~ a.-If we added the derived shadow (into the work list)-         [D] a ~ [b]-When we process it, we'll rewrite to a ~ [a] and get an-occurs check.  Without it we'll miss the occurs check (reporting-inaccessible code); but that's probably OK.--Note [Keep CDictCan shadows as CDictCan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-  class C a => D a b-and [G] D a b, [G] C a in the inert set.  Now we insert-[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,-so we can rewrite it with the new constraint, and perhaps get-instance reduction or other consequences.--BUT we do not want to kick out a *non-canonical* (D a b). If we-did, we would do this:-  - rewrite it to [D] D a c, with pend_sc = True-  - use expandSuperClasses to add C a-  - go round again, which solves C a from the givens-This loop goes on for ever and triggers the simpl_loop limit.--Solution: kick out the CDictCan which will have pend_sc = False,-because we've already added its superclasses.  So we won't re-add-them.  If we forget the pend_sc flag, our cunning scheme for avoiding-generating superclasses repeatedly will fail.--See #11379 for a case of this.--Note [Do not do improvement for WOnly]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do improvement between two constraints (e.g. for injectivity-or functional dependencies) only if both are "improvable". And-we improve a constraint wrt the top-level instances only if-it is improvable.--Improvable:     [G] [WD] [D}-Not improvable: [W]--Reasons:--* It's less work: fewer pairs to compare--* Every [W] has a shadow [D] so nothing is lost--* Consider [WD] C Int b,  where 'b' is a skolem, and-    class C a b | a -> b-    instance C Int Bool-  We'll do a fundep on it and emit [D] b ~ Bool-  That will kick out constraint [WD] C Int b-  Then we'll split it to [W] C Int b (keep in inert)-                     and [D] C Int b (in work list)-  When processing the latter we'll rewrite it to-        [D] C Int Bool-  At that point it would be /stupid/ to interact it-  with the inert [W] C Int b in the inert set; after all,-  it's the very constraint from which the [D] C Int Bool-  was split!  We can avoid this by not doing improvement-  on [W] constraints. This came up in #12860.--}--maybeEmitShadow :: InertCans -> Ct -> TcS Ct--- See Note [The improvement story and derived shadows]-maybeEmitShadow ics ct-  | let ev = ctEvidence ct-  , CtWanted { ctev_pred = pred, ctev_loc = loc-             , ctev_nosh = WDeriv } <- ev-  , shouldSplitWD (inert_eqs ics) (inert_funeqs ics) ct-  = do { traceTcS "Emit derived shadow" (ppr ct)-       ; let derived_ev = CtDerived { ctev_pred = pred-                                    , ctev_loc  = loc }-             shadow_ct = ct { cc_ev = derived_ev }-               -- Te shadow constraint keeps the canonical shape.-               -- This just saves work, but is sometimes important;-               -- see Note [Keep CDictCan shadows as CDictCan]-       ; emitWork [shadow_ct]--       ; let ev' = ev { ctev_nosh = WOnly }-             ct' = ct { cc_ev = ev' }-                 -- Record that it now has a shadow-                 -- This is /the/ place we set the flag to WOnly-       ; return ct' }--  | otherwise-  = return ct--shouldSplitWD :: InertEqs -> FunEqMap EqualCtList -> Ct -> Bool--- Precondition: 'ct' is [WD], and is inert--- True <=> we should split ct ito [W] and [D] because---          the inert_eqs can make progress on the [D]--- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CDictCan { cc_tyargs = tys })-  = should_split_match_args inert_eqs fun_eqs tys-    -- NB True: ignore coercions-    -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty-                                        , cc_eq_rel = eq_rel })-  =  tv `elemDVarEnv` inert_eqs-  || anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) ty-  -- NB False: do not ignore casts and coercions-  -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })-  = anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)-                          (ctEvPred ev)--shouldSplitWD inert_eqs fun_eqs (CIrredCan { cc_ev = ev })-  = anyRewritableCanEqLHS (ctEvEqRel ev) (canRewriteTv inert_eqs)-                          (canRewriteTyFam fun_eqs) (ctEvPred ev)--shouldSplitWD _ _ _ = False   -- No point in splitting otherwise--should_split_match_args :: InertEqs -> FunEqMap EqualCtList -> [TcType] -> Bool--- True if the inert_eqs can rewrite anything in the argument types-should_split_match_args inert_eqs fun_eqs tys-  = any (anyRewritableCanEqLHS NomEq (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)) tys-    -- See Note [Splitting WD constraints]--canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool-canRewriteTv inert_eqs eq_rel tv-  | Just (EqualCtList (ct :| _)) <- lookupDVarEnv inert_eqs tv-  , CEqCan { cc_eq_rel = eq_rel1 } <- ct-  = eq_rel1 `eqCanRewrite` eq_rel-  | otherwise-  = False--canRewriteTyFam :: FunEqMap EqualCtList -> EqRel -> TyCon -> [Type] -> Bool-canRewriteTyFam fun_eqs eq_rel tf args-  | Just (EqualCtList (ct :| _)) <- findFunEq fun_eqs tf args-  , CEqCan { cc_eq_rel = eq_rel1 } <- ct-  = eq_rel1 `eqCanRewrite` eq_rel-  | otherwise-  = False--isImprovable :: CtEvidence -> Bool--- See Note [Do not do improvement for WOnly]-isImprovable (CtWanted { ctev_nosh = WOnly }) = False-isImprovable _                                = True---{- *********************************************************************-*                                                                      *-                   Inert equalities-*                                                                      *-********************************************************************* -}--addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs-addTyEq old_eqs tv ct-  = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct)-  where-    add_eq old_eqs _ = addToEqualCtList ct old_eqs--addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct-            -> FunEqMap EqualCtList-addCanFunEq old_eqs fun_tc fun_args ct-  = alterTcApp old_eqs fun_tc fun_args upd-  where-    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list-    upd Nothing                  = Just $ unitEqualCtList ct--foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b-foldTyEqs k eqs z-  = foldDVarEnv (\(EqualCtList cts) z -> foldr k z cts) z eqs--findTyEqs :: InertCans -> TyVar -> [Ct]-findTyEqs icans tv = maybe [] id (fmap @Maybe equalCtListToList $-                                  lookupDVarEnv (inert_eqs icans) tv)--delEq :: InertCans -> CanEqLHS -> TcType -> InertCans-delEq ic lhs rhs = case lhs of-    TyVarLHS tv-      -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }-    TyFamLHS tf args-      -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }-  where-    isThisOne :: Ct -> Bool-    isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1-    isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)--    upd :: Maybe EqualCtList -> Maybe EqualCtList-    upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list-    upd Nothing           = Nothing--findEq :: InertCans -> CanEqLHS -> [Ct]-findEq icans (TyVarLHS tv) = findTyEqs icans tv-findEq icans (TyFamLHS fun_tc fun_args)-  = maybe [] id (fmap @Maybe equalCtListToList $-                 findFunEq (inert_funeqs icans) fun_tc fun_args)--{- *********************************************************************-*                                                                      *-                   Inert instances: inert_insts-*                                                                      *-********************************************************************* -}--addInertForAll :: QCInst -> TcS ()--- Add a local Given instance, typically arising from a type signature-addInertForAll new_qci-  = do { ics  <- getInertCans-       ; ics1 <- add_qci ics--       -- Update given equalities. C.f updateGivenEqs-       ; tclvl <- getTcLevel-       ; let pred         = qci_pred new_qci-             not_equality = isClassPred pred && not (isEqPred pred)-                  -- True <=> definitely not an equality-                  -- A qci_pred like (f a) might be an equality--             ics2 | not_equality = ics1-                  | otherwise    = ics1 { inert_given_eq_lvl = tclvl-                                        , inert_given_eqs    = True }--       ; setInertCans ics2 }-  where-    add_qci :: InertCans -> TcS InertCans-    -- See Note [Do not add duplicate quantified instances]-    add_qci ics@(IC { inert_insts = qcis })-      | any same_qci qcis-      = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci)-           ; return ics }--      | otherwise-      = do { traceTcS "adding new inert quantified instance" (ppr new_qci)-           ; return (ics { inert_insts = new_qci : qcis }) }--    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))-                                (ctEvPred (qci_ev new_qci))--{- Note [Do not add duplicate quantified instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#15244):--  f :: (C g, D g) => ....-  class S g => C g where ...-  class S g => D g where ...-  class (forall a. Eq a => Eq (g a)) => S g where ...--Then in f's RHS there are two identical quantified constraints-available, one via the superclasses of C and one via the superclasses-of D.  The two are identical, and it seems wrong to reject the program-because of that. But without doing duplicate-elimination we will have-two matching QCInsts when we try to solve constraints arising from f's-RHS.--The simplest thing is simply to eliminate duplicates, which we do here.--}--{- *********************************************************************-*                                                                      *-                  Adding an inert-*                                                                      *-************************************************************************--Note [Adding an equality to the InertCans]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When adding an equality to the inerts:--* Split [WD] into [W] and [D] if the inerts can rewrite the latter;-  done by maybeEmitShadow.--* Kick out any constraints that can be rewritten by the thing-  we are adding.  Done by kickOutRewritable.--* Note that unifying a:=ty, is like adding [G] a~ty; just use-  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.--}--addInertCan :: Ct -> TcS ()--- Precondition: item /is/ canonical--- See Note [Adding an equality to the InertCans]-addInertCan ct-  = do { traceTcS "addInertCan {" $-         text "Trying to insert new inert item:" <+> ppr ct--       ; ics <- getInertCans-       ; ct  <- maybeEmitShadow ics ct-       ; ics <- maybeKickOut ics ct-       ; tclvl <- getTcLevel-       ; setInertCans (add_item tclvl ics ct)--       ; traceTcS "addInertCan }" $ empty }--maybeKickOut :: InertCans -> Ct -> TcS InertCans--- For a CEqCan, kick out any inert that can be rewritten by the CEqCan-maybeKickOut ics ct-  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct-  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics-       ; return ics' }-  | otherwise-  = return ics--add_item :: TcLevel -> InertCans -> Ct -> InertCans-add_item tc_lvl-         ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })-         item@(CEqCan { cc_lhs = lhs })-  = updateGivenEqs tc_lvl item $-    case lhs of-       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item }-       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv item }--add_item tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})-  = updateGivenEqs tc_lvl item $   -- An Irred might turn out to be an-                                 -- equality, so we play safe-    ics { inert_irreds = irreds `Bag.snocBag` item }--add_item _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item }--add_item _ _ item-  = pprPanic "upd_inert set: can't happen! Inserting " $-    ppr item   -- Can't be CNonCanonical because they only land in inert_irreds--updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans--- Set the inert_given_eq_level to the current level (tclvl)--- if the constraint is a given equality that should prevent--- filling in an outer unification variable.--- See See Note [Tracking Given equalities]-updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })-  | not (isGivenCt ct) = inerts-  | not_equality ct    = inerts -- See Note [Let-bound skolems]-  | otherwise          = inerts { inert_given_eq_lvl = ge_lvl'-                                , inert_given_eqs    = True }-  where-    ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct)-              -- Includes things like (c a), which *might* be an equality-            = tclvl-            | otherwise-            = ge_lvl--    not_equality :: Ct -> Bool-    -- True <=> definitely not an equality of any kind-    --          except for a let-bound skolem, which doesn't count-    --          See Note [Let-bound skolems]-    -- NB: no need to spot the boxed CDictCan (a ~ b) because its-    --     superclass (a ~# b) will be a CEqCan-    not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv)-    not_equality (CDictCan {})                     = True-    not_equality _                                 = False--------------------------------------------kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that-                                      -- is being added to the inert set-                   -> CanEqLHS        -- The new equality is lhs ~ ty-                   -> InertCans-                   -> TcS (Int, InertCans)-kickOutRewritable new_fr new_lhs ics-  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_lhs ics-             n_kicked = workListSize kicked_out--       ; unless (n_kicked == 0) $-         do { updWorkListTcS (appendWorkList kicked_out)--              -- The famapp-cache contains Given evidence from the inert set.-              -- If we're kicking out Givens, we need to remove this evidence-              -- from the cache, too.-            ; let kicked_given_ev_vars =-                    [ ev_var | ct <- wl_eqs kicked_out-                             , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]-            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&-                   -- if this isn't true, no use looking through the constraints-                    not (null kicked_given_ev_vars)) $-              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"-                            (ppr kicked_given_ev_vars)-                 ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }--            ; csTraceTcS $-              hang (text "Kick out, lhs =" <+> ppr new_lhs)-                 2 (vcat [ text "n-kicked =" <+> int n_kicked-                         , text "kicked_out =" <+> ppr kicked_out-                         , text "Residual inerts =" <+> ppr ics' ]) }--       ; return (n_kicked, ics') }--kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that-                                      -- is being added to the inert set-                    -> CanEqLHS       -- The new equality is lhs ~ ty-                    -> InertCans-                    -> (WorkList, InertCans)--- See Note [kickOutRewritable]-kick_out_rewritable new_fr new_lhs-                    ics@(IC { inert_eqs      = tv_eqs-                            , inert_dicts    = dictmap-                            , inert_funeqs   = funeqmap-                            , inert_irreds   = irreds-                            , inert_insts    = old_insts })-  | not (new_fr `eqMayRewriteFR` new_fr)-  = (emptyWorkList, ics)-        -- If new_fr can't rewrite itself, it can't rewrite-        -- anything else, so no need to kick out anything.-        -- (This is a common case: wanteds can't rewrite wanteds)-        -- Lemma (L2) in Note [Extending the inert equalities]--  | otherwise-  = (kicked_out, inert_cans_in)-  where-    -- inert_safehask stays unchanged; is that right?-    inert_cans_in = ics { inert_eqs      = tv_eqs_in-                        , inert_dicts    = dicts_in-                        , inert_funeqs   = feqs_in-                        , inert_irreds   = irs_in-                        , inert_insts    = insts_in }--    kicked_out :: WorkList-    -- NB: use extendWorkList to ensure that kicked-out equalities get priority-    -- See Note [Prioritise equalities] (Kick-out).-    -- The irreds may include non-canonical (hetero-kinded) equality-    -- constraints, which perhaps may have become soluble after new_lhs-    -- is substituted; ditto the dictionaries, which may include (a~b)-    -- or (a~~b) constraints.-    kicked_out = foldr extendWorkListCt-                          (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })-                          ((dicts_out `andCts` irs_out)-                            `extendCtsList` insts_out)--    (tv_eqs_out, tv_eqs_in) = foldDVarEnv (kick_out_eqs extend_tv_eqs)-                                          ([], emptyDVarEnv) tv_eqs-    (feqs_out,   feqs_in)   = foldFunEqs  (kick_out_eqs extend_fun_eqs)-                                          funeqmap ([], emptyFunEqs)-    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap-    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds-      -- Kick out even insolubles: See Note [Rewrite insolubles]-      -- Of course we must kick out irreducibles like (c a), in case-      -- we can rewrite 'c' to something more useful--    -- Kick-out for inert instances-    -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical-    insts_out :: [Ct]-    insts_in  :: [QCInst]-    (insts_out, insts_in)-       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens-       = partitionWith kick_out_qci old_insts-       | otherwise-       = ([], old_insts)-    kick_out_qci qci-      | let ev = qci_ev qci-      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))-      = Left (mkNonCanonical ev)-      | otherwise-      = Right qci--    (_, new_role) = new_fr--    fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool-    fr_tv_can_rewrite_ty new_tv role ty-      = anyRewritableTyVar True role can_rewrite ty-                  -- True: ignore casts and coercions-      where-        can_rewrite :: EqRel -> TyVar -> Bool-        can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv--    fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool-    fr_tf_can_rewrite_ty new_tf new_tf_args role ty-      = anyRewritableTyFamApp role can_rewrite ty-      where-        can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool-        can_rewrite old_role old_tf old_tf_args-          = new_role `eqCanRewrite` old_role &&-            tcEqTyConApps new_tf new_tf_args old_tf old_tf_args-              -- it's possible for old_tf_args to have too many. This is fine;-              -- we'll only check what we need to.--    {-# INLINE fr_can_rewrite_ty #-}   -- perform the check here only once-    fr_can_rewrite_ty :: EqRel -> Type -> Bool-    fr_can_rewrite_ty = case new_lhs of-      TyVarLHS new_tv             -> fr_tv_can_rewrite_ty new_tv-      TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args--    fr_may_rewrite :: CtFlavourRole -> Bool-    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs-        -- Can the new item rewrite the inert item?--    {-# INLINE kick_out_ct #-}   -- perform case on new_lhs here only once-    kick_out_ct :: Ct -> Bool-    -- Kick it out if the new CEqCan can rewrite the inert one-    -- See Note [kickOutRewritable]-    kick_out_ct = case new_lhs of-      TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in-                                fr_may_rewrite fs-                             && fr_tv_can_rewrite_ty new_tv role (ctPred ct)-      TyFamLHS new_tf new_tf_args-        -> \ct -> let fs@(_, role) = ctFlavourRole ct in-                  fr_may_rewrite fs-               && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)--    extend_tv_eqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs-    extend_tv_eqs eqs (TyVarLHS tv) cts = extendDVarEnv eqs tv cts-    extend_tv_eqs eqs other _cts = pprPanic "extend_tv_eqs" (ppr eqs $$ ppr other)--    extend_fun_eqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList-                   -> FunEqMap EqualCtList-    extend_fun_eqs eqs (TyFamLHS fam_tc fam_args) cts-      = insertTcApp eqs fam_tc fam_args cts-    extend_fun_eqs eqs other _cts = pprPanic "extend_fun_eqs" (ppr eqs $$ ppr other)--    kick_out_eqs :: (container -> CanEqLHS -> EqualCtList -> container)-                 -> EqualCtList -> ([Ct], container)-                 -> ([Ct], container)-    kick_out_eqs extend eqs (acc_out, acc_in)-      = (eqs_out `chkAppend` acc_out, case listToEqualCtList eqs_in of-            Nothing -> acc_in-            Just eqs_in_ecl@(EqualCtList (eq1 :| _))-                    -> extend acc_in (cc_lhs eq1) eqs_in_ecl)-      where-        (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs)--    -- Implements criteria K1-K3 in Note [Extending the inert equalities]-    kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty-                        , cc_ev = ev, cc_eq_rel = eq_rel })-      | not (fr_may_rewrite fs)-      = False  -- (K0) Keep it in the inert set if the new thing can't rewrite it--      -- Below here (fr_may_rewrite fs) is True--      | TyVarLHS _ <- lhs-      , fs `eqMayRewriteFR` new_fr-      = False  -- (K4) Keep it in the inert set if the LHS is a tyvar and-               -- it can rewrite the work item. See Note [K4]--      | fr_can_rewrite_ty eq_rel (canEqLHSType lhs)-      = True   -- (K1)-         -- The above check redundantly checks the role & flavour,-         -- but it's very convenient--      | kick_out_for_inertness    = True   -- (K2)-      | kick_out_for_completeness = True   -- (K3)-      | otherwise                 = False--      where-        fs = (ctEvFlavour ev, eq_rel)-        kick_out_for_inertness-          =    (fs `eqMayRewriteFR` fs)           -- (K2a)-            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2b)--        kick_out_for_completeness  -- (K3) and Note [K3: completeness of solving]-          = case eq_rel of-              NomEq  -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)-              ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty    -- (K3b)--    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)--    is_can_eq_lhs_head (TyVarLHS tv) = go-      where-        go (Rep.TyVarTy tv')   = tv == tv'-        go (Rep.AppTy fun _)   = go fun-        go (Rep.CastTy ty _)   = go ty-        go (Rep.TyConApp {})   = False-        go (Rep.LitTy {})      = False-        go (Rep.ForAllTy {})   = False-        go (Rep.FunTy {})      = False-        go (Rep.CoercionTy {}) = False-    is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go-      where-        go (Rep.TyVarTy {})       = False-        go (Rep.AppTy {})         = False  -- no TyConApp to the left of an AppTy-        go (Rep.CastTy ty _)      = go ty-        go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args-        go (Rep.LitTy {})         = False-        go (Rep.ForAllTy {})      = False-        go (Rep.FunTy {})         = False-        go (Rep.CoercionTy {})    = False--kickOutAfterUnification :: TcTyVar -> TcS Int-kickOutAfterUnification new_tv-  = do { ics <- getInertCans-       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)-                                                 (TyVarLHS new_tv) ics-                     -- Given because the tv := xi is given; NomEq because-                     -- only nominal equalities are solved by unification--       ; setInertCans ics2-       ; return n_kicked }---- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS ()-kickOutAfterFillingCoercionHole hole filled_co-  = do { ics <- getInertCans-       ; let (kicked_out, ics') = kick_out ics-             n_kicked           = workListSize kicked_out--       ; unless (n_kicked == 0) $-         do { updWorkListTcS (appendWorkList kicked_out)-            ; csTraceTcS $-              hang (text "Kick out, hole =" <+> ppr hole)-                 2 (vcat [ text "n-kicked =" <+> int n_kicked-                         , text "kicked_out =" <+> ppr kicked_out-                         , text "Residual inerts =" <+> ppr ics' ]) }--       ; setInertCans ics' }-  where-    holes_of_co = coercionHolesOfCo filled_co--    kick_out :: InertCans -> (WorkList, InertCans)-    kick_out ics@(IC { inert_irreds = irreds })-      = let (to_kick, to_keep) = partitionBagWith kick_ct irreds--            kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList-            ics'       = ics { inert_irreds = to_keep }-        in-        (kicked_out, ics')--    kick_ct :: Ct -> Either Ct Ct-         -- Left: kick out; Right: keep. But even if we keep, we may need-         -- to update the set of blocking holes-    kick_ct ct@(CIrredCan { cc_status = BlockedCIS holes })-      | hole `elementOfUniqSet` holes-      = let new_holes = holes `delOneFromUniqSet` hole-                              `unionUniqSets` holes_of_co-            updated_ct = ct { cc_status = BlockedCIS new_holes }-        in-        if isEmptyUniqSet new_holes-        then Left updated_ct-        else Right updated_ct-    kick_ct other = Right other--{- Note [kickOutRewritable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [inert_eqs: the inert equalities].--When we add a new inert equality (lhs ~N ty) to the inert set,-we must kick out any inert items that could be rewritten by the-new equality, to maintain the inert-set invariants.--  - We want to kick out an existing inert constraint if-    a) the new constraint can rewrite the inert one-    b) 'lhs' is free in the inert constraint (so that it *will*)-       rewrite it if we kick it out.--    For (b) we use anyRewritableCanLHS, which examines the types /and-    kinds/ that are directly visible in the type. Hence-    we will have exposed all the rewriting we care about to make the-    most precise kinds visible for matching classes etc. No need to-    kick out constraints that mention type variables whose kinds-    contain this LHS!--  - A Derived equality can kick out [D] constraints in inert_eqs,-    inert_dicts, inert_irreds etc.--  - We don't kick out constraints from inert_solved_dicts, and-    inert_solved_funeqs optimistically. But when we lookup we have to-    take the substitution into account--NB: we could in principle avoid kick-out:-  a) When unifying a meta-tyvar from an outer level, because-     then the entire implication will be iterated; see-     Note [The Unification Level Flag]--  b) For Givens, after a unification.  By (GivenInv) in GHC.Tc.Utils.TcType-     Note [TcLevel invariants], a Given can't include a meta-tyvar from-     its own level, so it falls under (a).  Of course, we must still-     kick out Givens when adding a new non-unification Given.--But kicking out more vigorously may lead to earlier unification and fewer-iterations, so we don't take advantage of these possibilities.--Note [Rewrite insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have an insoluble alpha ~ [alpha], which is insoluble-because an occurs check.  And then we unify alpha := [Int].  Then we-really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can-be decomposed.  Otherwise we end up with a "Can't match [Int] ~-[[Int]]" which is true, but a bit confusing because the outer type-constructors match.--Hence:- * In the main simplifier loops in GHC.Tc.Solver (solveWanteds,-   simpl_loop), we feed the insolubles in solveSimpleWanteds,-   so that they get rewritten (albeit not solved).-- * We kick insolubles out of the inert set, if they can be-   rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)-- * We rewrite those insolubles in GHC.Tc.Solver.Canonical.-   See Note [Make sure that insolubles are fully rewritten]--}-------------------addInertSafehask :: InertCans -> Ct -> InertCans-addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item }--addInertSafehask _ item-  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item--insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver-insertSafeOverlapFailureTcS what item-  | safeOverlap what = return ()-  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)--getSafeOverlapFailures :: TcS Cts--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver-getSafeOverlapFailures- = do { IC { inert_safehask = safehask } <- getInertCans-      ; return $ foldDicts consCts safehask emptyCts }-----------------addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()--- Conditionally add a new item in the solved set of the monad--- See Note [Solved dictionaries]-addSolvedDict what item cls tys-  | isWanted item-  , instanceReturnsDictCon what-  = do { traceTcS "updSolvedSetTcs:" $ ppr item-       ; updInertTcS $ \ ics ->-             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }-  | otherwise-  = return ()--getSolvedDicts :: TcS (DictMap CtEvidence)-getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }--setSolvedDicts :: DictMap CtEvidence -> TcS ()-setSolvedDicts solved_dicts-  = updInertTcS $ \ ics ->-    ics { inert_solved_dicts = solved_dicts }---{- *********************************************************************-*                                                                      *-                  Other inert-set operations-*                                                                      *-********************************************************************* -}--updInertTcS :: (InertSet -> InertSet) -> TcS ()--- Modify the inert set with the supplied function-updInertTcS upd_fn-  = do { is_var <- getTcSInertsRef-       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var-                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }--getInertCans :: TcS InertCans-getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }--setInertCans :: InertCans -> TcS ()-setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }--updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a--- Modify the inert set with the supplied function-updRetInertCans upd_fn-  = do { is_var <- getTcSInertsRef-       ; wrapTcS (do { inerts <- TcM.readTcRef is_var-                     ; let (res, cans') = upd_fn (inert_cans inerts)-                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })-                     ; return res }) }--updInertCans :: (InertCans -> InertCans) -> TcS ()--- Modify the inert set with the supplied function-updInertCans upd_fn-  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }--updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()--- Modify the inert set with the supplied function-updInertDicts upd_fn-  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }--updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()--- Modify the inert set with the supplied function-updInertSafehask upd_fn-  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }--updInertIrreds :: (Cts -> Cts) -> TcS ()--- Modify the inert set with the supplied function-updInertIrreds upd_fn-  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }--getInertEqs :: TcS (DTyVarEnv EqualCtList)-getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }--getInnermostGivenEqLevel :: TcS TcLevel-getInnermostGivenEqLevel = do { inert <- getInertCans-                              ; return (inert_given_eq_lvl inert) }--getInertInsols :: TcS Cts--- Returns insoluble equality constraints--- specifically including Givens-getInertInsols = do { inert <- getInertCans-                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }--getInertGivens :: TcS [Ct]--- Returns the Given constraints in the inert set-getInertGivens-  = do { inerts <- getInertCans-       ; let all_cts = foldDicts (:) (inert_dicts inerts)-                     $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out)-                                  (inert_funeqs inerts)-                     $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts))-       ; return (filter isGivenCt all_cts) }--getPendingGivenScs :: TcS [Ct]--- Find all inert Given dictionaries, or quantified constraints,---     whose cc_pend_sc flag is True---     and that belong to the current level--- Set their cc_pend_sc flag to False in the inert set, and return that Ct-getPendingGivenScs = do { lvl <- getTcLevel-                        ; updRetInertCans (get_sc_pending lvl) }--get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)-get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })-  = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )-       -- When getPendingScDics is called,-       -- there are never any Wanteds in the inert set-    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })-  where-    sc_pending = sc_pend_insts ++ sc_pend_dicts--    sc_pend_dicts = foldDicts get_pending dicts []-    dicts' = foldr add dicts sc_pend_dicts--    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts--    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True-                                       -- but flipping the flag-    get_pending dict dicts-        | Just dict' <- isPendingScDict dict-        , belongs_to_this_level (ctEvidence dict)-        = dict' : dicts-        | otherwise-        = dicts--    add :: Ct -> DictMap Ct -> DictMap Ct-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts-        = addDictCt dicts cls tys ct-    add ct _ = pprPanic "getPendingScDicts" (ppr ct)--    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)-    get_pending_inst cts qci@(QCI { qci_ev = ev })-       | Just qci' <- isPendingScInst qci-       , belongs_to_this_level ev-       = (CQuantCan qci' : cts, qci')-       | otherwise-       = (cts, qci)--    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl-    -- We only want Givens from this level; see (3a) in-    -- Note [The superclass story] in GHC.Tc.Solver.Canonical--getUnsolvedInerts :: TcS ( Bag Implication-                         , Cts )   -- All simple constraints--- Return all the unsolved [Wanted] or [Derived] constraints------ Post-condition: the returned simple constraints are all fully zonked---                     (because they come from the inert set)---                 the unsolved implics may not be-getUnsolvedInerts- = do { IC { inert_eqs    = tv_eqs-           , inert_funeqs = fun_eqs-           , inert_irreds = irreds-           , inert_dicts  = idicts-           } <- getInertCans--      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts-            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts-            unsolved_irreds  = Bag.filterBag is_unsolved irreds-            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts-            unsolved_others  = unsolved_irreds `unionBags` unsolved_dicts--      ; implics <- getWorkListImplics--      ; traceTcS "getUnsolvedInerts" $-        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs-             , text "fun eqs =" <+> ppr unsolved_fun_eqs-             , text "others =" <+> ppr unsolved_others-             , text "implics =" <+> ppr implics ]--      ; return ( implics, unsolved_tv_eqs `unionBags`-                          unsolved_fun_eqs `unionBags`-                          unsolved_others) }-  where-    add_if_unsolved :: Ct -> Cts -> Cts-    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts-                           | otherwise      = cts--    add_if_unsolveds :: EqualCtList -> Cts -> Cts-    add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts-                                             (equalCtListToList new_cts)--    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived--getHasGivenEqs :: TcLevel           -- TcLevel of this implication-               -> TcS ( HasGivenEqs -- are there Given equalities?-                      , Cts )       -- Insoluble equalities arising from givens--- See Note [Tracking Given equalities]-getHasGivenEqs tclvl-  = do { inerts@(IC { inert_irreds       = irreds-                    , inert_given_eqs    = given_eqs-                    , inert_given_eq_lvl = ge_lvl })-              <- getInertCans-       ; let insols = filterBag insolubleEqCt irreds-                      -- Specifically includes ones that originated in some-                      -- outer context but were refined to an insoluble by-                      -- a local equality; so do /not/ add ct_given_here.--             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and-             -- Note [Tracking Given equalities] in this module-             has_ge | ge_lvl == tclvl = MaybeGivenEqs-                    | given_eqs       = LocalGivenEqs-                    | otherwise       = NoGivenEqs--       ; traceTcS "getHasGivenEqs" $-         vcat [ text "given_eqs:" <+> ppr given_eqs-              , text "ge_lvl:" <+> ppr ge_lvl-              , text "ambient level:" <+> ppr tclvl-              , text "Inerts:" <+> ppr inerts-              , text "Insols:" <+> ppr insols]-       ; return (has_ge, insols) }--mentionsOuterVar :: TcLevel -> CtEvidence -> Bool-mentionsOuterVar tclvl ev-  = anyFreeVarsOfType (isOuterTyVar tclvl) $-    ctEvPred ev--isOuterTyVar :: TcLevel -> TyCoVar -> Bool--- True of a type variable that comes from a--- shallower level than the ambient level (tclvl)-isOuterTyVar tclvl tv-  | isTyVar tv = ASSERT2( not (isTouchableMetaTyVar tclvl tv), ppr tv <+> ppr tclvl  )-                 tclvl `strictlyDeeperThan` tcTyVarLevel tv-    -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from-    -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't-    -- be a touchable meta tyvar.   If this wasn't true, you might worry that,-    -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby-    -- becomes "outer" even though its level numbers says it isn't.-  | otherwise  = False  -- Coercion variables; doesn't much matter---- | Returns Given constraints that might,--- potentially, match the given pred. This is used when checking to see if a--- Given might overlap with an instance. See Note [Instance and Given overlap]--- in "GHC.Tc.Solver.Interact"-matchableGivens :: CtLoc -> PredType -> InertSet -> Cts-matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans })-  = filterBag matchable_given all_relevant_givens-  where-    -- just look in class constraints and irreds. matchableGivens does get called-    -- for ~R constraints, but we don't need to look through equalities, because-    -- canonical equalities are used for rewriting. We'll only get caught by-    -- non-canonical -- that is, irreducible -- equalities.-    all_relevant_givens :: Cts-    all_relevant_givens-      | Just (clas, _) <- getClassPredTys_maybe pred_w-      = findDictsByClass (inert_dicts inert_cans) clas-        `unionBags` inert_irreds inert_cans-      | otherwise-      = inert_irreds inert_cans--    matchable_given :: Ct -> Bool-    matchable_given ct-      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct-      = mightEqualLater inerts pred_g loc_g pred_w loc_w--      | otherwise-      = False--mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool--- See Note [What might equal later?]--- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact-mightEqualLater (IS { inert_cycle_breakers = cbvs })-                given_pred given_loc wanted_pred wanted_loc-  | prohibitedSuperClassSolve given_loc wanted_loc-  = False--  | otherwise-  = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of-      SurelyApart              -> False  -- types that are surely apart do not equal later-      MaybeApart MARInfinite _ -> False  -- see Example 7 in the Note.-      _                        -> True--  where-    in_scope  = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred]--    -- NB: flatten both at the same time, so that we can share mappings-    -- from type family applications to variables, and also to guarantee-    -- 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]--    bind_fun :: BindFun-    bind_fun tv rhs_ty-      | isMetaTyVar tv-      , can_unify tv (metaTyVarInfo tv) rhs_ty-         -- this checks for CycleBreakerTvs and TyVarTvs; forgetting-         -- the latter was #19106.-      = BindMe--         -- See Examples 4, 5, and 6 from the Note-      | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv-      , anyFreeVarsOfTypes mentions_meta_ty_var fam_args-      = BindMe--      | otherwise-      = Apart--    -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars-    -- (as they can be unified)-    -- and also for CycleBreakerTvs that mentions meta-tyvars-    mentions_meta_ty_var :: TyVar -> Bool-    mentions_meta_ty_var tv-      | isMetaTyVar tv-      = case metaTyVarInfo tv of-          -- See Examples 8 and 9 in the Note-          CycleBreakerTv-            | Just tyfam_app <- lookup tv cbvs-            -> anyFreeVarsOfType mentions_meta_ty_var tyfam_app-            | otherwise-            -> pprPanic "mightEqualLater finds an unbound cbv" (ppr tv $$ ppr cbvs)-          _ -> True-      | otherwise-      = False--    -- like canSolveByUnification, but allows cbv variables to unify-    can_unify :: TcTyVar -> MetaInfo -> Type -> Bool-    can_unify _lhs_tv TyVarTv rhs_ty  -- see Example 3 from the Note-      | Just rhs_tv <- tcGetTyVar_maybe rhs_ty-      = case tcTyVarDetails rhs_tv of-          MetaTv { mtv_info = TyVarTv } -> True-          MetaTv {}                     -> False  -- could unify with anything-          SkolemTv {}                   -> True-          RuntimeUnk                    -> True-      | otherwise  -- not a var on the RHS-      = False-    can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv--prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool--- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance-prohibitedSuperClassSolve from_loc solve_loc-  | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc-  , ScOrigin wanted_size <- ctLocOrigin solve_loc-  = given_size >= wanted_size-  | otherwise-  = False--{- Note [Unsolved Derived equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In getUnsolvedInerts, we return a derived equality from the inert_eqs-because it is a candidate for floating out of this implication.  We-only float equalities with a meta-tyvar on the left, so we only pull-those out here.--Note [What might equal later?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must determine whether a Given might later equal a Wanted. We-definitely need to account for the possibility that any metavariable-might be arbitrarily instantiated. Yet we do *not* want-to allow skolems in to be instantiated, as we've already rewritten-with respect to any Givens. (We're solving a Wanted here, and so-all Givens have already been processed.)--This is best understood by example.--1. C alpha  ~?  C Int--   That given certainly might match later.--2. C a  ~?  C Int--   No. No new givens are going to arise that will get the `a` to rewrite-   to Int.--3. C alpha[tv]   ~?  C Int--   That alpha[tv] is a TyVarTv, unifiable only with other type variables.-   It cannot equal later.--4. C (F alpha)   ~?   C Int--   Sure -- that can equal later, if we learn something useful about alpha.--5. C (F alpha[tv])  ~?  C Int--   This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere.-   Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other,-   and F x x = Int. Remember: returning True doesn't commit ourselves to-   anything.--6. C (F a)  ~?  C a--   No, this won't match later. If we could rewrite (F a) or a, we would-   have by now.--7. C (Maybe alpha)  ~?  C alpha--   We say this cannot equal later, because it would require-   alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived,-   we choose not to worry about it. See Note [Infinitary substitution in lookup]-   in GHC.Core.InstEnv. Getting this wrong let to #19107, tested in-   typecheck/should_compile/T19107.--8. C cbv   ~?  C Int-   where cbv = F a--   The cbv is a cycle-breaker var which stands for F a. See-   Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical.-   This is just like case 6, and we say "no". Saying "no" here is-   essential in getting the parser to type-check, with its use of DisambECP.--9. C cbv   ~?   C Int-   where cbv = F alpha--   Here, we might indeed equal later. Distinguishing between-   this case and Example 8 is why we need the InertSet in mightEqualLater.--10. C (F alpha, Int)  ~?  C (Bool, F alpha)--   This cannot equal later, because F a would have to equal both Bool and-   Int.--To deal with type family applications, we use the Core flattener. See-Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.-The Core flattener replaces all type family applications with-fresh variables. The next question: should we allow these fresh-variables in the domain of a unifying substitution?--A type family application that mentions only skolems (example 6) is settled:-any skolems would have been rewritten w.r.t. Givens by now. These type family-applications match only themselves. A type family application that mentions-metavariables, on the other hand, can match anything. So, if the original type-family application contains a metavariable, we use BindMe to tell the unifier-to allow it in the substitution. On the other hand, a type family application-with only skolems is considered rigid.--This treatment fixes #18910 and is tested in-typecheck/should_compile/InstanceGivenOverlap{,2}--}--removeInertCts :: [Ct] -> InertCans -> InertCans--- ^ Remove inert constraints from the 'InertCans', for use when a--- typechecker plugin wishes to discard a given.-removeInertCts cts icans = foldl' removeInertCt icans cts--removeInertCt :: InertCans -> Ct -> InertCans-removeInertCt is ct =-  case ct of--    CDictCan  { cc_class = cl, cc_tyargs = tys } ->-      is { inert_dicts = delDict (inert_dicts is) cl tys }--    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs--    CQuantCan {}     -> panic "removeInertCt: CQuantCan"-    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"-    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"---- | Looks up a family application in the inerts; returned coercion--- is oriented input ~ output-lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavourRole))-lookupFamAppInert fam_tc tys-  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts-       ; return (lookup_inerts inert_funeqs) }-  where-    lookup_inerts inert_funeqs-      | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _))-          <- findFunEq inert_funeqs fam_tc tys-      = Just (ctEvCoercion ctev, rhs, ctEvFlavourRole ctev)-      | otherwise = Nothing--lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)--- Is this exact predicate type cached in the solved or canonicals of the InertSet?-lookupInInerts loc pty-  | ClassPred cls tys <- classifyPredType pty-  = do { inerts <- getTcSInerts-       ; return (lookupSolvedDict inerts loc cls tys `mplus`-                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }-  | otherwise -- NB: No caching for equalities, IPs, holes, or errors-  = return Nothing---- | Look up a dictionary inert.-lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct-lookupInertDict (IC { inert_dicts = dicts }) loc cls tys-  = case findDict dicts loc cls tys of-      Just ct -> Just ct-      _       -> Nothing---- | Look up a solved inert.-lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence--- Returns just if exactly this predicate type exists in the solved.-lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys-  = case findDict solved loc cls tys of-      Just ev -> Just ev-      _       -> Nothing------------------------------lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))-lookupFamAppCache fam_tc tys-  = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts-       ; case findFunEq famapp_cache fam_tc tys of-           result@(Just (co, ty)) ->-             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)-                                                    , ppr ty-                                                    , ppr co ])-                ; return result }-           Nothing -> return Nothing }--extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()--- NB: co :: rhs ~ F tys, to match expectations of rewriter-extendFamAppCache tc xi_args stuff@(_, ty)-  = do { dflags <- getDynFlags-       ; when (gopt Opt_FamAppCache dflags) $-    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args-                                            , ppr ty ])-            -- 'co' can be bottom, in the case of derived items-       ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->-            is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }---- Remove entries from the cache whose evidence mentions variables in the--- supplied set-dropFromFamAppCache :: VarSet -> TcS ()-dropFromFamAppCache varset-  = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts-       ; let filtered = filterTcAppMap check famapp_cache-       ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }-  where-    check :: (TcCoercion, TcType) -> Bool-    check (co, _) = not (anyFreeVarsOfCo (`elemVarSet` varset) co)--{- *********************************************************************-*                                                                      *-                   Irreds-*                                                                      *-********************************************************************* -}--foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b-foldIrreds k irreds z = foldr k z irreds---{- *********************************************************************-*                                                                      *-                   TcAppMap-*                                                                      *-************************************************************************--Note [Use loose types in inert set]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we are looking up an inert dictionary (CDictCan) or function-equality (CEqCan), we use a TcAppMap, which uses the Unique of the-class/type family tycon and then a trie which maps the arguments. This-trie does *not* need to match the kinds of the arguments; this Note-explains why.--Consider the types ty0 = (T ty1 ty2 ty3 ty4) and ty0' = (T ty1' ty2' ty3' ty4'),-where ty4 and ty4' have different kinds. Let's further assume that both types-ty0 and ty0' are well-typed. Because the kind of T is closed, it must be that-one of the ty1..ty3 does not match ty1'..ty3' (and that the kind of the fourth-argument to T is dependent on whichever one changed). Since we are matching-all arguments, during the inert-set lookup, we know that ty1..ty3 do indeed-match ty1'..ty3'. Therefore, the kind of ty4 and ty4' must match, too ---without ever looking at it.--Accordingly, we use LooseTypeMap, which skips the kind check when looking-up a type. I (Richard E) believe this is just an optimization, and that-looking at kinds would be harmless.---}--type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a)-    -- Indexed by tycon then the arg types, using "loose" matching, where-    -- we don't require kind equality. This allows, for example, (a |> co)-    -- to match (a).-    -- See Note [Use loose types in inert set]-    -- Used for types and classes; hence UniqDFM-    -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here--isEmptyTcAppMap :: TcAppMap a -> Bool-isEmptyTcAppMap m = isEmptyDTyConEnv m--emptyTcAppMap :: TcAppMap a-emptyTcAppMap = emptyDTyConEnv--findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a-findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc-                        ; lookupTM tys tys_map }--delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a-delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc--insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a-insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc-  where-    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))--alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a-alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc-  where-    alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)-    alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))--filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a-filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m-  where-    one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)-    one_tycon tm-      | isEmptyTM filtered_tm = Nothing-      | otherwise             = Just filtered_tm-      where-        filtered_tm = filterTM f tm--tcAppMapToBag :: TcAppMap a -> Bag a-tcAppMapToBag m = foldTcAppMap consBag m emptyBag--foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b-foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m---{- *********************************************************************-*                                                                      *-                   DictMap-*                                                                      *-********************************************************************* -}---{- Note [Tuples hiding implicit parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f,g :: (?x::Int, C a) => a -> a-   f v = let ?x = 4 in g v--The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).-We must /not/ solve this from the Given (?x::Int, C a), because of-the intervening binding for (?x::Int).  #14218.--We deal with this by arranging that we always fail when looking up a-tuple constraint that hides an implicit parameter. Not that this applies-  * both to the inert_dicts (lookupInertDict)-  * and to the solved_dicts (looukpSolvedDict)-An alternative would be not to extend these sets with such tuple-constraints, but it seemed more direct to deal with the lookup.--Note [Solving CallStack constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose f :: HasCallStack => blah.  Then--* Each call to 'f' gives rise to-    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f-  with a CtOrigin that says "OccurrenceOf f".-  Remember that HasCallStack is just shorthand for-    IP "callStack CallStack-  See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence--* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by-  pushing the call-site info on the stack, and changing the CtOrigin-  to record that has been done.-   Bind:  s1 = pushCallStack <site-info> s2-   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin--* Then, and only then, we can solve the constraint from an enclosing-  Given.--So we must be careful /not/ to solve 's1' from the Givens.  Again,-we ensure this by arranging that findDict always misses when looking-up souch constraints.--}--type DictMap a = TcAppMap a--emptyDictMap :: DictMap a-emptyDictMap = emptyTcAppMap--findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a-findDict m loc cls tys-  | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]-  = Nothing--  | Just {} <- isCallStackPred cls tys-  , OccurrenceOf {} <- ctLocOrigin loc-  = Nothing             -- See Note [Solving CallStack constraints]--  | otherwise-  = findTcApp m (classTyCon cls) tys--findDictsByClass :: DictMap a -> Class -> Bag a-findDictsByClass m cls-  | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag-  | otherwise                                     = emptyBag--delDict :: DictMap a -> Class -> [Type] -> DictMap a-delDict m cls tys = delTcApp m (classTyCon cls) tys--addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a-addDict m cls tys item = insertTcApp m (classTyCon cls) tys item--addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct--- Like addDict, but combines [W] and [D] to [WD]--- See Note [KeepBoth] in GHC.Tc.Solver.Interact-addDictCt m cls tys new_ct = alterTcApp m (classTyCon cls) tys xt_ct-  where-    new_ct_ev = ctEvidence new_ct--    xt_ct :: Maybe Ct -> Maybe Ct-    xt_ct (Just old_ct)-      | CtWanted { ctev_nosh = WOnly } <- old_ct_ev-      , CtDerived {} <- new_ct_ev-      = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }})-      | CtDerived {} <- old_ct_ev-      , CtWanted { ctev_nosh = WOnly } <- new_ct_ev-      = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }})-      where-        old_ct_ev = ctEvidence old_ct--    xt_ct _ = Just new_ct--addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct-addDictsByClass m cls items-  = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)-  where-    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm-    add ct _ = pprPanic "addDictsByClass" (ppr ct)--filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct-filterDicts f m = filterTcAppMap f m--partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)-partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)-  where-    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)-                       | otherwise = (yeses,              add ct noes)-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m-      = addDict m cls tys ct-    add ct _ = pprPanic "partitionDicts" (ppr ct)--dictsToBag :: DictMap a -> Bag a-dictsToBag = tcAppMapToBag--foldDicts :: (a -> b -> b) -> DictMap a -> b -> b-foldDicts = foldTcAppMap--emptyDicts :: DictMap a-emptyDicts = emptyTcAppMap---{- *********************************************************************-*                                                                      *-                   FunEqMap-*                                                                      *-********************************************************************* -}--type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair--emptyFunEqs :: TcAppMap a-emptyFunEqs = emptyTcAppMap--findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a-findFunEq m tc tys = findTcApp m tc tys--findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]--- Get inert function equation constraints that have the given tycon--- in their head.  Not that the constraints remain in the inert set.--- We use this to check for derived interactions with built-in type-function--- constructors.-findFunEqsByTyCon m tc-  | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []-  | otherwise                       = []--foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b-foldFunEqs = foldTcAppMap--insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a-insertFunEq m tc tys val = insertTcApp m tc tys val--{--************************************************************************-*                                                                      *-*              The TcS solver monad                                    *-*                                                                      *-************************************************************************--Note [The TcS monad]-~~~~~~~~~~~~~~~~~~~~-The TcS monad is a weak form of the main Tc monad--All you can do is-    * fail-    * allocate new variables-    * fill in evidence variables--Filling in a dictionary evidence variable means to create a binding-for it, so TcS carries a mutable location where the binding can be-added.  This is initialised from the innermost implication constraint.--}--data TcSEnv-  = TcSEnv {-      tcs_ev_binds    :: EvBindsVar,--      tcs_unified     :: IORef Int,-         -- The number of unification variables we have filled-         -- The important thing is whether it is non-zero--      tcs_unif_lvl  :: IORef (Maybe TcLevel),-         -- The Unification Level Flag-         -- Outermost level at which we have unified a meta tyvar-         -- Starts at Nothing, then (Just i), then (Just j) where j<i-         -- See Note [The Unification Level Flag]--      tcs_count     :: IORef Int, -- Global step count--      tcs_inerts    :: IORef InertSet, -- Current inert set--      -- See Note [WorkList priorities] and-      tcs_worklist  :: IORef WorkList -- Current worklist-    }------------------newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)---- | Smart constructor for 'TcS', as describe in Note [The one-shot state--- monad trick] in "GHC.Utils.Monad".-mkTcS :: (TcSEnv -> TcM a) -> TcS a-mkTcS f = TcS (oneShot f)--instance Applicative TcS where-  pure x = mkTcS $ \_ -> return x-  (<*>) = ap--instance Monad TcS where-  m >>= k   = mkTcS $ \ebs -> do-    unTcS m ebs >>= (\r -> unTcS (k r) ebs)--instance MonadFail TcS where-  fail err  = mkTcS $ \_ -> fail err--instance MonadUnique TcS where-   getUniqueSupplyM = wrapTcS getUniqueSupplyM--instance HasModule TcS where-   getModule = wrapTcS getModule--instance MonadThings TcS where-   lookupThing n = wrapTcS (lookupThing n)---- Basic functionality--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-wrapTcS :: TcM a -> TcS a--- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,--- and TcS is supposed to have limited functionality-wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds--wrapErrTcS :: TcM a -> TcS a--- The thing wrapped should just fail--- There's no static check; it's up to the user--- Having a variant for each error message is too painful-wrapErrTcS = wrapTcS--wrapWarnTcS :: TcM a -> TcS a--- The thing wrapped should just add a warning, or no-op--- There's no static check; it's up to the user-wrapWarnTcS = wrapTcS--failTcS, panicTcS  :: SDoc -> TcS a-warnTcS   :: WarningFlag -> SDoc -> TcS ()-addErrTcS :: SDoc -> TcS ()-failTcS      = wrapTcS . TcM.failWith-warnTcS flag = wrapTcS . TcM.addDiagnostic (WarningWithFlag flag)-addErrTcS    = wrapTcS . TcM.addErr-panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc--traceTcS :: String -> SDoc -> TcS ()-traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)-{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]--runTcPluginTcS :: TcPluginM a -> TcS a-runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar--instance HasDynFlags TcS where-    getDynFlags = wrapTcS getDynFlags--getGlobalRdrEnvTcS :: TcS GlobalRdrEnv-getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv--bumpStepCountTcS :: TcS ()-bumpStepCountTcS = mkTcS $ \env ->-  do { let ref = tcs_count env-     ; n <- TcM.readTcRef ref-     ; TcM.writeTcRef ref (n+1) }--csTraceTcS :: SDoc -> TcS ()-csTraceTcS doc-  = wrapTcS $ csTraceTcM (return doc)-{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]--traceFireTcS :: CtEvidence -> SDoc -> TcS ()--- Dump a rule-firing trace-traceFireTcS ev doc-  = mkTcS $ \env -> csTraceTcM $-    do { n <- TcM.readTcRef (tcs_count env)-       ; tclvl <- TcM.getTcLevel-       ; return (hang (text "Step" <+> int n-                       <> brackets (text "l:" <> ppr tclvl <> comma <>-                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))-                       <+> doc <> colon)-                     4 (ppr ev)) }-{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]--csTraceTcM :: TcM SDoc -> TcM ()--- Constraint-solver tracing, -ddump-cs-trace-csTraceTcM mk_doc-  = do { dflags <- getDynFlags-       ; when (  dopt Opt_D_dump_cs_trace dflags-                  || dopt Opt_D_dump_tc_trace dflags )-              ( do { msg <- mk_doc-                   ; TcM.dumpTcRn False-                       Opt_D_dump_cs_trace-                       "" FormatText-                       msg }) }-{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]--runTcS :: TcS a                -- What to run-       -> TcM (a, EvBindMap)-runTcS tcs-  = do { ev_binds_var <- TcM.newTcEvBinds-       ; res <- runTcSWithEvBinds ev_binds_var tcs-       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var-       ; return (res, ev_binds) }--- | This variant of 'runTcS' will keep solving, even when only Deriveds--- are left around. It also doesn't return any evidence, as callers won't--- need it.-runTcSDeriveds :: TcS a -> TcM a-runTcSDeriveds tcs-  = do { ev_binds_var <- TcM.newTcEvBinds-       ; runTcSWithEvBinds ev_binds_var tcs }---- | This can deal only with equality constraints.-runTcSEqualities :: TcS a -> TcM a-runTcSEqualities thing_inside-  = do { ev_binds_var <- TcM.newNoTcEvBinds-       ; runTcSWithEvBinds ev_binds_var thing_inside }---- | A variant of 'runTcS' that takes and returns an 'InertSet' for--- later resumption of the 'TcS' session.-runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)-runTcSInerts inerts tcs = do-  ev_binds_var <- TcM.newTcEvBinds-  runTcSWithEvBinds' False ev_binds_var $ do-    setTcSInerts inerts-    a <- tcs-    new_inerts <- getTcSInerts-    return (a, new_inerts)--runTcSWithEvBinds :: EvBindsVar-                  -> TcS a-                  -> TcM a-runTcSWithEvBinds = runTcSWithEvBinds' True--runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?-                           -- Don't if you want to reuse the InertSet.-                           -- See also Note [Type variable cycles in Givens]-                           -- in GHC.Tc.Solver.Canonical-                   -> EvBindsVar-                   -> TcS a-                   -> TcM a-runTcSWithEvBinds' restore_cycles ev_binds_var tcs-  = do { unified_var <- TcM.newTcRef 0-       ; step_count <- TcM.newTcRef 0-       ; inert_var <- TcM.newTcRef emptyInert-       ; wl_var <- TcM.newTcRef emptyWorkList-       ; unif_lvl_var <- TcM.newTcRef Nothing-       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var-                          , tcs_unified       = unified_var-                          , tcs_unif_lvl      = unif_lvl_var-                          , tcs_count         = step_count-                          , tcs_inerts        = inert_var-                          , tcs_worklist      = wl_var }--             -- Run the computation-       ; res <- unTcS tcs env--       ; count <- TcM.readTcRef step_count-       ; when (count > 0) $-         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)--       ; when restore_cycles $-         do { inert_set <- TcM.readTcRef inert_var-            ; restoreTyVarCycles inert_set }--#if defined(DEBUG)-       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var-       ; checkForCyclicBinds ev_binds-#endif--       ; return res }-------------------------------#if defined(DEBUG)-checkForCyclicBinds :: EvBindMap -> TcM ()-checkForCyclicBinds ev_binds_map-  | null cycles-  = return ()-  | null coercion_cycles-  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles-  | otherwise-  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles-  where-    ev_binds = evBindMapBinds ev_binds_map--    cycles :: [[EvBind]]-    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]--    coercion_cycles = [c | c <- cycles, any is_co_bind c]-    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)--    edges :: [ Node EvVar EvBind ]-    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))-            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]-            -- It's OK to use nonDetEltsUFM here as-            -- stronglyConnCompFromEdgedVertices is still deterministic even-            -- if the edges are in nondeterministic order as explained in-            -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.-#endif-------------------------------setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a-setEvBindsTcS ref (TcS thing_inside)- = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })--nestImplicTcS :: EvBindsVar-              -> TcLevel -> TcS a-              -> TcS a-nestImplicTcS ref inner_tclvl (TcS thing_inside)-  = TcS $ \ TcSEnv { tcs_unified       = unified_var-                   , tcs_inerts        = old_inert_var-                   , tcs_count         = count-                   , tcs_unif_lvl      = unif_lvl-                   } ->-    do { inerts <- TcM.readTcRef old_inert_var-       ; let nest_inert = inerts { inert_cycle_breakers = []-                                 , inert_cans = (inert_cans inerts)-                                                   { inert_given_eqs = False } }-                 -- All other InertSet fields are inherited-       ; new_inert_var <- TcM.newTcRef nest_inert-       ; new_wl_var    <- TcM.newTcRef emptyWorkList-       ; let nest_env = TcSEnv { tcs_count         = count     -- Inherited-                               , tcs_unif_lvl      = unif_lvl  -- Inherited-                               , tcs_ev_binds      = ref-                               , tcs_unified       = unified_var-                               , tcs_inerts        = new_inert_var-                               , tcs_worklist      = new_wl_var }-       ; res <- TcM.setTcLevel inner_tclvl $-                thing_inside nest_env--       ; out_inert_set <- TcM.readTcRef new_inert_var-       ; restoreTyVarCycles out_inert_set--#if defined(DEBUG)-       -- Perform a check that the thing_inside did not cause cycles-       ; ev_binds <- TcM.getTcEvBindsMap ref-       ; checkForCyclicBinds ev_binds-#endif-       ; return res }--nestTcS ::  TcS a -> TcS a--- Use the current untouchables, augmenting the current--- evidence bindings, and solved dictionaries--- But have no effect on the InertCans, or on the inert_famapp_cache--- (we want to inherit the latter from processing the Givens)-nestTcS (TcS thing_inside)-  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->-    do { inerts <- TcM.readTcRef inerts_var-       ; new_inert_var <- TcM.newTcRef inerts-       ; new_wl_var    <- TcM.newTcRef emptyWorkList-       ; let nest_env = env { tcs_inerts   = new_inert_var-                            , tcs_worklist = new_wl_var }--       ; res <- thing_inside nest_env--       ; new_inerts <- TcM.readTcRef new_inert_var--       -- we want to propagate the safe haskell failures-       ; let old_ic = inert_cans inerts-             new_ic = inert_cans new_inerts-             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }--       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]-                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts-                                , inert_cans = nxt_ic })--       ; return res }--emitImplicationTcS :: TcLevel -> SkolemInfo-                   -> [TcTyVar]        -- Skolems-                   -> [EvVar]          -- Givens-                   -> Cts              -- Wanteds-                   -> TcS TcEvBinds--- Add an implication to the TcS monad work-list-emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds-  = do { let wc = emptyWC { wc_simple = wanteds }-       ; imp <- wrapTcS $-                do { ev_binds_var <- TcM.newTcEvBinds-                   ; imp <- TcM.newImplication-                   ; return (imp { ic_tclvl  = new_tclvl-                                 , ic_skols  = skol_tvs-                                 , ic_given  = givens-                                 , ic_wanted = wc-                                 , ic_binds  = ev_binds_var-                                 , ic_info   = skol_info }) }--       ; emitImplication imp-       ; return (TcEvBinds (ic_binds imp)) }--emitTvImplicationTcS :: TcLevel -> SkolemInfo-                     -> [TcTyVar]        -- Skolems-                     -> Cts              -- Wanteds-                     -> TcS ()--- Just like emitImplicationTcS but no givens and no bindings-emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds-  = do { let wc = emptyWC { wc_simple = wanteds }-       ; imp <- wrapTcS $-                do { ev_binds_var <- TcM.newNoTcEvBinds-                   ; imp <- TcM.newImplication-                   ; return (imp { ic_tclvl  = new_tclvl-                                 , ic_skols  = skol_tvs-                                 , ic_wanted = wc-                                 , ic_binds  = ev_binds_var-                                 , ic_info   = skol_info }) }--       ; emitImplication imp }---{- Note [Propagate the solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's really quite important that nestTcS does not discard the solved-dictionaries from the thing_inside.-Consider-   Eq [a]-   forall b. empty =>  Eq [a]-We solve the simple (Eq [a]), under nestTcS, and then turn our attention to-the implications.  It's definitely fine to use the solved dictionaries on-the inner implications, and it can make a significant performance difference-if you do so.--}---- Getters and setters of GHC.Tc.Utils.Env fields--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Getter of inerts and worklist-getTcSInertsRef :: TcS (IORef InertSet)-getTcSInertsRef = TcS (return . tcs_inerts)--getTcSWorkListRef :: TcS (IORef WorkList)-getTcSWorkListRef = TcS (return . tcs_worklist)--getTcSInerts :: TcS InertSet-getTcSInerts = getTcSInertsRef >>= readTcRef--setTcSInerts :: InertSet -> TcS ()-setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }--getWorkListImplics :: TcS (Bag Implication)-getWorkListImplics-  = do { wl_var <- getTcSWorkListRef-       ; wl_curr <- readTcRef wl_var-       ; return (wl_implics wl_curr) }--pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)--- Push the level and run thing_inside--- However, thing_inside should not generate any work items-#if defined(DEBUG)-pushLevelNoWorkList err_doc (TcS thing_inside)-  = TcS (\env -> TcM.pushTcLevelM $-                 thing_inside (env { tcs_worklist = wl_panic })-        )-  where-    wl_panic  = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc-                         -- This panic checks that the thing-inside-                         -- does not emit any work-list constraints-#else-pushLevelNoWorkList _ (TcS thing_inside)-  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check-#endif--updWorkListTcS :: (WorkList -> WorkList) -> TcS ()-updWorkListTcS f-  = do { wl_var <- getTcSWorkListRef-       ; updTcRef wl_var f }--emitWorkNC :: [CtEvidence] -> TcS ()-emitWorkNC evs-  | null evs-  = return ()-  | otherwise-  = emitWork (map mkNonCanonical evs)--emitWork :: [Ct] -> TcS ()-emitWork [] = return ()   -- avoid printing, among other work-emitWork cts-  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))-       ; updWorkListTcS (extendWorkListCts cts) }--emitImplication :: Implication -> TcS ()-emitImplication implic-  = updWorkListTcS (extendWorkListImplic implic)--newTcRef :: a -> TcS (TcRef a)-newTcRef x = wrapTcS (TcM.newTcRef x)--readTcRef :: TcRef a -> TcS a-readTcRef ref = wrapTcS (TcM.readTcRef ref)--writeTcRef :: TcRef a -> a -> TcS ()-writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)--updTcRef :: TcRef a -> (a->a) -> TcS ()-updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)--getTcEvBindsVar :: TcS EvBindsVar-getTcEvBindsVar = TcS (return . tcs_ev_binds)--getTcLevel :: TcS TcLevel-getTcLevel = wrapTcS TcM.getTcLevel--getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet-getTcEvTyCoVars ev_binds_var-  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var--getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap-getTcEvBindsMap ev_binds_var-  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var--setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()-setTcEvBindsMap ev_binds_var binds-  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds--unifyTyVar :: TcTyVar -> TcType -> TcS ()--- Unify a meta-tyvar with a type--- We keep track of how many unifications have happened in tcs_unified,------ We should never unify the same variable twice!-unifyTyVar tv ty-  = ASSERT2( isMetaTyVar tv, ppr tv )-    TcS $ \ env ->-    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)-       ; TcM.writeMetaTyVar tv ty-       ; TcM.updTcRef (tcs_unified env) (+1) }--reportUnifications :: TcS a -> TcS (Int, a)-reportUnifications (TcS thing_inside)-  = TcS $ \ env ->-    do { inner_unified <- TcM.newTcRef 0-       ; res <- thing_inside (env { tcs_unified = inner_unified })-       ; n_unifs <- TcM.readTcRef inner_unified-       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)-       ; return (n_unifs, res) }--getDefaultInfo ::  TcS ([Type], (Bool, Bool))-getDefaultInfo = wrapTcS TcM.tcGetDefaultTys---- Just get some environments needed for instance looking up and matching--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--getInstEnvs :: TcS InstEnvs-getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs--getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)-getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs--getTopEnv :: TcS HscEnv-getTopEnv = wrapTcS $ TcM.getTopEnv--getGblEnv :: TcS TcGblEnv-getGblEnv = wrapTcS $ TcM.getGblEnv--getLclEnv :: TcS TcLclEnv-getLclEnv = wrapTcS $ TcM.getLclEnv--tcLookupClass :: Name -> TcS Class-tcLookupClass c = wrapTcS $ TcM.tcLookupClass c--tcLookupId :: Name -> TcS Id-tcLookupId n = wrapTcS $ TcM.tcLookupId n---- Setting names as used (used in the deriving of Coercible evidence)--- Too hackish to expose it to TcS? In that case somehow extract the used--- constructors from the result of solveInteract-addUsedGREs :: [GlobalRdrElt] -> TcS ()-addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres--addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()-addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre--keepAlive :: Name -> TcS ()-keepAlive = wrapTcS . TcM.keepAlive---- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()--- Check that we do not try to use an instance before it is available.  E.g.---    instance Eq T where ...---    f x = $( ... (\(p::T) -> p == p)... )--- Here we can't use the equality function from the instance in the splice--checkWellStagedDFun loc what pred-  | TopLevInstance { iw_dfun_id = dfun_id } <- what-  , let bind_lvl = TcM.topIdLvl dfun_id-  , bind_lvl > impLevel-  = wrapTcS $ TcM.setCtLocM loc $-    do { use_stage <- TcM.getStage-       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }--  | otherwise-  = return ()    -- Fast path for common case-  where-    pp_thing = text "instance for" <+> quotes (ppr pred)--pprEq :: TcType -> TcType -> SDoc-pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2--isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)-isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)--isFilledMetaTyVar :: TcTyVar -> TcS Bool-isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)--zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet-zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)--zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]-zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)--zonkCo :: Coercion -> TcS Coercion-zonkCo = wrapTcS . TcM.zonkCo--zonkTcType :: TcType -> TcS TcType-zonkTcType ty = wrapTcS (TcM.zonkTcType ty)--zonkTcTypes :: [TcType] -> TcS [TcType]-zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)--zonkTcTyVar :: TcTyVar -> TcS TcType-zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)--zonkSimples :: Cts -> TcS Cts-zonkSimples cts = wrapTcS (TcM.zonkSimples cts)--zonkWC :: WantedConstraints -> TcS WantedConstraints-zonkWC wc = wrapTcS (TcM.zonkWC wc)--zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar-zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)-------------------------------pprKicked :: Int -> SDoc-pprKicked 0 = empty-pprKicked n = parens (int n <+> text "kicked out")--{- *********************************************************************-*                                                                      *-*              The Unification Level Flag                              *-*                                                                      *-********************************************************************* -}--{- Note [The Unification Level Flag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a deep tree of implication constraints-   forall[1] a.                              -- Outer-implic-      C alpha[1]                               -- Simple-      forall[2] c. ....(C alpha[1])....        -- Implic-1-      forall[2] b. ....(alpha[1] ~ Int)....    -- Implic-2--The (C alpha) is insoluble until we know alpha.  We solve alpha-by unifying alpha:=Int somewhere deep inside Implic-2. But then we-must try to solve the Outer-implic all over again. This time we can-solve (C alpha) both in Outer-implic, and nested inside Implic-1.--When should we iterate solving a level-n implication?-Answer: if any unification of a tyvar at level n takes place-        in the ic_implics of that implication.--* What if a unification takes place at level n-1? Then don't iterate-  level n, because we'll iterate level n-1, and that will in turn iterate-  level n.--* What if a unification takes place at level n, in the ic_simples of-  level n?  No need to track this, because the kick-out mechanism deals-  with it.  (We can't drop kick-out in favour of iteration, because kick-out-  works for skolem-equalities, not just unifications.)--So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps-track of-  - Whether any unifications at all have taken place (Nothing => no unifications)-  - If so, what is the outermost level that has seen a unification (Just lvl)--The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver.--It helpful not to iterate unless there is a chance of progress.  #8474 is-an example:--  * There's a deeply-nested chain of implication constraints.-       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int--  * From the innermost one we get a [D] alpha[1] ~ Int,-    so we can unify.--  * It's better not to iterate the inner implications, but go all the-    way out to level 1 before iterating -- because iterating level 1-    will iterate the inner levels anyway.--(In the olden days when we "floated" thse Derived constraints, this was-much, much more important -- we got exponential behaviour, as each iteration-produced the same Derived constraint.)--}---resetUnificationFlag :: TcS Bool--- We are at ambient level i--- If the unification flag = Just i, reset it to Nothing and return True--- Otherwise leave it unchanged and return False-resetUnificationFlag-  = TcS $ \env ->-    do { let ref = tcs_unif_lvl env-       ; ambient_lvl <- TcM.getTcLevel-       ; mb_lvl <- TcM.readTcRef ref-       ; TcM.traceTc "resetUnificationFlag" $-         vcat [ text "ambient:" <+> ppr ambient_lvl-              , text "unif_lvl:" <+> ppr mb_lvl ]-       ; case mb_lvl of-           Nothing       -> return False-           Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl-                         -> return False-                         | otherwise-                         -> do { TcM.writeTcRef ref Nothing-                               ; return True } }--setUnificationFlag :: TcLevel -> TcS ()--- (setUnificationFlag i) sets the unification level to (Just i)--- unless it already is (Just j) where j <= i-setUnificationFlag lvl-  = TcS $ \env ->-    do { let ref = tcs_unif_lvl env-       ; mb_lvl <- TcM.readTcRef ref-       ; case mb_lvl of-           Just unif_lvl | lvl `deeperThanOrSame` unif_lvl-                         -> return ()-           _ -> TcM.writeTcRef ref (Just lvl) }---{- *********************************************************************-*                                                                      *-*                Instantiation etc.-*                                                                      *-********************************************************************* -}---- Instantiations--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)-instDFunType dfun_id inst_tys-  = wrapTcS $ TcM.instDFunType dfun_id inst_tys--newFlexiTcSTy :: Kind -> TcS TcType-newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)--cloneMetaTyVar :: TcTyVar -> TcS TcTyVar-cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)--instFlexi :: [TKVar] -> TcS TCvSubst-instFlexi = instFlexiX emptyTCvSubst--instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst-instFlexiX subst tvs-  = wrapTcS (foldlM instFlexiHelper subst tvs)--instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst-instFlexiHelper subst tv-  = do { uniq <- TcM.newUnique-       ; details <- TcM.newMetaDetails TauTv-       ; let name = setNameUnique (tyVarName tv) uniq-             kind = substTyUnchecked subst (tyVarKind tv)-             ty'  = mkTyVarTy (mkTcTyVar name kind details)-       ; TcM.traceTc "instFlexi" (ppr ty')-       ; return (extendTvSubst subst tv ty') }--matchGlobalInst :: DynFlags-                -> Bool      -- True <=> caller is the short-cut solver-                             -- See Note [Shortcut solving: overlap]-                -> Class -> [Type] -> TcS TcM.ClsInstResult-matchGlobalInst dflags short_cut cls tys-  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)--tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])-tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs---- Creating and setting evidence variables and CtFlavors--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--data MaybeNew = Fresh CtEvidence | Cached EvExpr--isFresh :: MaybeNew -> Bool-isFresh (Fresh {})  = True-isFresh (Cached {}) = False--freshGoals :: [MaybeNew] -> [CtEvidence]-freshGoals mns = [ ctev | Fresh ctev <- mns ]--getEvExpr :: MaybeNew -> EvExpr-getEvExpr (Fresh ctev) = ctEvExpr ctev-getEvExpr (Cached evt) = evt--setEvBind :: EvBind -> TcS ()-setEvBind ev_bind-  = do { evb <- getTcEvBindsVar-       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }---- | Mark variables as used filling a coercion hole-useVars :: CoVarSet -> TcS ()-useVars co_vars-  = do { ev_binds_var <- getTcEvBindsVar-       ; let ref = ebv_tcvs ev_binds_var-       ; wrapTcS $-         do { tcvs <- TcM.readTcRef ref-            ; let tcvs' = tcvs `unionVarSet` co_vars-            ; TcM.writeTcRef ref tcvs' } }---- | Equalities only-setWantedEq :: TcEvDest -> Coercion -> TcS ()-setWantedEq (HoleDest hole) co-  = do { useVars (coVarsOfCo co)-       ; fillCoercionHole hole co }-setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)---- | Good for both equalities and non-equalities-setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()-setWantedEvTerm (HoleDest hole) tm-  | Just co <- evTermCoercion_maybe tm-  = do { useVars (coVarsOfCo co)-       ; fillCoercionHole hole co }-  | otherwise-  = -- See Note [Yukky eq_sel for a HoleDest]-    do { let co_var = coHoleCoVar hole-       ; setEvBind (mkWantedEvBind co_var tm)-       ; fillCoercionHole hole (mkTcCoVarCo co_var) }--setWantedEvTerm (EvVarDest ev_id) tm-  = setEvBind (mkWantedEvBind ev_id tm)--{- Note [Yukky eq_sel for a HoleDest]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-How can it be that a Wanted with HoleDest gets evidence that isn't-just a coercion? i.e. evTermCoercion_maybe returns Nothing.--Consider [G] forall a. blah => a ~ T-         [W] S ~# T--Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~-T) in the quantified constraints, and wraps the (boxed) evidence it-gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put-that term into a coercion, so we add a value binding-    h = eq_sel (...)-and the coercion variable h to fill the coercion hole.-We even re-use the CoHole's Id for this binding!--Yuk!--}--fillCoercionHole :: CoercionHole -> Coercion -> TcS ()-fillCoercionHole hole co-  = do { wrapTcS $ TcM.fillCoercionHole hole co-       ; kickOutAfterFillingCoercionHole hole co }--setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()-setEvBindIfWanted ev tm-  = case ev of-      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm-      _                             -> return ()--newTcEvBinds :: TcS EvBindsVar-newTcEvBinds = wrapTcS TcM.newTcEvBinds--newNoTcEvBinds :: TcS EvBindsVar-newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds--newEvVar :: TcPredType -> TcS EvVar-newEvVar pred = wrapTcS (TcM.newEvVar pred)--newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence--- Make a new variable of the given PredType,--- immediately bind it to the given term--- and return its CtEvidence--- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint-newGivenEvVar loc (pred, rhs)-  = do { new_ev <- newBoundEvVarId pred rhs-       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }---- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the--- given term-newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar-newBoundEvVarId pred rhs-  = do { new_ev <- newEvVar pred-       ; setEvBind (mkGivenEvBind new_ev rhs)-       ; return new_ev }--newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]-newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts--emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion--- | Emit a new Wanted equality into the work-list-emitNewWantedEq loc role ty1 ty2-  = do { (ev, co) <- newWantedEq loc role ty1 ty2-       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))-       ; return co }---- | Make a new equality CtEvidence-newWantedEq :: CtLoc -> Role -> TcType -> TcType-            -> TcS (CtEvidence, Coercion)-newWantedEq = newWantedEq_SI WDeriv--newWantedEq_SI :: ShadowInfo -> CtLoc -> Role-               -> TcType -> TcType-               -> TcS (CtEvidence, Coercion)-newWantedEq_SI si loc role ty1 ty2-  = do { hole <- wrapTcS $ TcM.newCoercionHole pty-       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)-       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole-                           , ctev_nosh = si-                           , ctev_loc = loc}-                , mkHoleCo hole ) }-  where-    pty = mkPrimEqPredRole role ty1 ty2---- no equalities here. Use newWantedEq instead-newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence-newWantedEvVarNC = newWantedEvVarNC_SI WDeriv--newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence--- Don't look up in the solved/inerts; we know it's not there-newWantedEvVarNC_SI si loc pty-  = do { new_ev <- newEvVar pty-       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$-                                         pprCtLoc loc)-       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev-                          , ctev_nosh = si-                          , ctev_loc = loc })}--newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew-newWantedEvVar = newWantedEvVar_SI WDeriv--newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew--- For anything except ClassPred, this is the same as newWantedEvVarNC-newWantedEvVar_SI si loc pty-  = do { mb_ct <- lookupInInerts loc pty-       ; case mb_ct of-            Just ctev-              | not (isDerived ctev)-              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev-                    ; return $ Cached (ctEvExpr ctev) }-            _ -> do { ctev <- newWantedEvVarNC_SI si loc pty-                    ; return (Fresh ctev) } }--newWanted :: CtLoc -> PredType -> TcS MaybeNew--- Deals with both equalities and non equalities. Tries to look--- up non-equalities in the cache-newWanted = newWanted_SI WDeriv--newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew-newWanted_SI si loc pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2-  | otherwise-  = newWantedEvVar_SI si loc pty---- deals with both equalities and non equalities. Doesn't do any cache lookups.-newWantedNC :: CtLoc -> PredType -> TcS CtEvidence-newWantedNC loc pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = fst <$> newWantedEq loc role ty1 ty2-  | otherwise-  = newWantedEvVarNC loc pty--emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()-emitNewDeriveds loc preds-  | null preds-  = return ()-  | otherwise-  = do { evs <- mapM (newDerivedNC loc) preds-       ; traceTcS "Emitting new deriveds" (ppr evs)-       ; updWorkListTcS (extendWorkListDeriveds evs) }--emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()--- Create new equality Derived and put it in the work list--- There's no caching, no lookupInInerts-emitNewDerivedEq loc role ty1 ty2-  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)-       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)-       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }-         -- Very important: put in the wl_eqs-         -- See Note [Prioritise equalities] (Avoiding fundep iteration)--newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence-newDerivedNC loc pred-  = return $ CtDerived { ctev_pred = pred, ctev_loc = loc }---- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? ------------ | Checks if the depth of the given location is too much. Fails if--- it's too big, with an appropriate error message.-checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced-                    -> TcS ()-checkReductionDepth loc ty-  = do { dflags <- getDynFlags-       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $-         wrapErrTcS $-         solverDepthErrorTcS loc ty }--matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType))--- Given (F tys) return (ty, co), where co :: ty ~N F tys-matchFam tycon args = fmap (fmap (first mkTcSymCo)) $ wrapTcS $ matchFamTcM tycon args--matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType))--- Given (F tys) return (ty, co), where co :: F tys ~N ty-matchFamTcM tycon args-  = do { fam_envs <- FamInst.tcGetFamInstEnvs-       ; let match_fam_result-              = reduceTyFamApp_maybe fam_envs Nominal tycon args-       ; TcM.traceTc "matchFamTcM" $-         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)-              , ppr_res match_fam_result ]-       ; return match_fam_result }-  where-    ppr_res Nothing        = text "Match failed"-    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")-                                2 (vcat [ text "Rewrites to:" <+> ppr ty-                                        , text "Coercion:" <+> ppr co ])--{--Note [Residual implications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The wl_implics in the WorkList are the residual implication-constraints that are generated while solving or canonicalising the-current worklist.  Specifically, when canonicalising-   (forall a. t1 ~ forall a. t2)-from which we get the implication-   (forall a. t1 ~ t2)-See GHC.Tc.Solver.Monad.deferTcSForAllEq--}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | Monadic definitions for the constraint solver+module GHC.Tc.Solver.Monad (++    -- The TcS monad+    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, runTcSInerts,+    failTcS, warnTcS, addErrTcS, wrapTcS,+    runTcSEqualities,+    nestTcS, nestImplicTcS, setEvBindsTcS,+    emitImplicationTcS, emitTvImplicationTcS,++    selectNextWorkItem,+    getWorkList,+    updWorkListTcS,+    pushLevelNoWorkList,++    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,+    matchGlobalInst, TcM.ClsInstResult(..),++    QCInst(..),++    -- Tracing etc+    panicTcS, traceTcS,+    traceFireTcS, bumpStepCountTcS, csTraceTcS,+    wrapErrTcS, wrapWarnTcS,+    resetUnificationFlag, setUnificationFlag,++    -- Evidence creation and transformation+    MaybeNew(..), freshGoals, isFresh, getEvExpr,++    newTcEvBinds, newNoTcEvBinds,+    newWantedEq, newWantedEq_SI, emitNewWantedEq,+    newWanted, newWanted_SI, newWantedEvVar,+    newWantedNC, newWantedEvVarNC,+    newDerivedNC,+    newBoundEvVarId,+    unifyTyVar, reportUnifications,+    setEvBind, setWantedEq,+    setWantedEvTerm, setEvBindIfWanted,+    newEvVar, newGivenEvVar, newGivenEvVars,+    emitNewDeriveds, emitNewDerivedEq,+    checkReductionDepth,+    getSolvedDicts, setSolvedDicts,++    getInstEnvs, getFamInstEnvs,                -- Getting the environments+    getTopEnv, getGblEnv, getLclEnv,+    getTcEvBindsVar, getTcLevel,+    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,+    tcLookupClass, tcLookupId,++    -- Inerts+    updInertTcS, updInertCans, updInertDicts, updInertIrreds,+    getHasGivenEqs, setInertCans,+    getInertEqs, getInertCans, getInertGivens,+    getInertInsols, getInnermostGivenEqLevel,+    getTcSInerts, setTcSInerts,+    getUnsolvedInerts,+    removeInertCts, getPendingGivenScs,+    addInertCan, insertFunEq, addInertForAll,+    emitWorkNC, emitWork,+    isImprovable,+    lookupInertDict,++    -- The Model+    kickOutAfterUnification,++    -- Inert Safe Haskell safe-overlap failures+    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,+    getSafeOverlapFailures,++    -- Inert solved dictionaries+    addSolvedDict, lookupSolvedDict,++    -- Irreds+    foldIrreds,++    -- The family application cache+    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,+    pprKicked,++    instDFunType,                              -- Instantiation++    -- MetaTyVars+    newFlexiTcSTy, instFlexi, instFlexiX,+    cloneMetaTyVar,+    tcInstSkolTyVarsX,++    TcLevel,+    isFilledMetaTyVar_maybe, isFilledMetaTyVar,+    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,+    zonkTyCoVarsAndFVList,+    zonkSimples, zonkWC,+    zonkTyCoVarKind,++    -- References+    newTcRef, readTcRef, writeTcRef, updTcRef,++    -- Misc+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,+    matchFam, matchFamTcM,+    checkWellStagedDFun,+    pprEq,                                   -- Smaller utils, re-exported from TcM+                                             -- TODO (DV): these are only really used in the+                                             -- instance matcher in GHC.Tc.Solver. I am wondering+                                             -- if the whole instance matcher simply belongs+                                             -- here++    breakTyVarCycle, rewriterView+) where++import GHC.Prelude++import GHC.Driver.Env++import qualified GHC.Tc.Utils.Instantiate as TcM+import GHC.Core.InstEnv+import GHC.Tc.Instance.Family as FamInst+import GHC.Core.FamInstEnv++import qualified GHC.Tc.Utils.Monad    as TcM+import qualified GHC.Tc.Utils.TcMType  as TcM+import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )+import qualified GHC.Tc.Utils.Env      as TcM+       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )+import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )+import GHC.Tc.Utils.TcType+import GHC.Driver.Session+import GHC.Core.Type+import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally+import GHC.Core.Coercion++import GHC.Tc.Solver.Types+import GHC.Tc.Solver.InertSet++import GHC.Tc.Types.Evidence+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Tc.Errors   ( solverDepthErrorTcS )++import GHC.Types.Name+import GHC.Types.TyThing+import GHC.Unit.Module ( HasModule, getModule )+import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )+import qualified GHC.Rename.Env as TcM+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger+import GHC.Data.Bag as Bag+import GHC.Types.Unique.Supply+import GHC.Tc.Types+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Constraint+import GHC.Core.Predicate++import GHC.Types.Unique.Set++import Control.Monad+import GHC.Utils.Monad+import Data.IORef+import GHC.Exts (oneShot)+import Data.List ( mapAccumL )+import Data.List.NonEmpty ( NonEmpty(..) )+import Control.Arrow ( first )++#if defined(DEBUG)+import GHC.Data.Graph.Directed+#endif++{- *********************************************************************+*                                                                      *+             Shadow constraints and improvement+*                                                                      *+************************************************************************++Note [The improvement story and derived shadows]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not+rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for+solving.  Here's a classic example (indexed-types/should_fail/T4093a)++    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e++    We get [G] Foo e ~ Maybe e    (CEqCan)+           [W] Foo ee ~ Foo e     (CEqCan)       -- ee is a unification variable+           [W] Foo ee ~ Maybe ee  (CEqCan)++    The first Wanted gets rewritten to++           [W] Foo ee ~ Maybe e++    But now we appear to be stuck, since we don't rewrite Wanteds with+    Wanteds.  This is silly because we can see that ee := e is the+    only solution.++The basic plan is+  * generate Derived constraints that shadow Wanted constraints+  * allow Derived to rewrite Derived+  * in order to cause some unifications to take place+  * that in turn solve the original Wanteds++The ONLY reason for all these Derived equalities is to tell us how to+unify a variable: that is, what Mark Jones calls "improvement".++The same idea is sometimes also called "saturation"; find all the+equalities that must hold in any solution.++Or, equivalently, you can think of the derived shadows as implementing+the "model": a non-idempotent but no-occurs-check substitution,+reflecting *all* *Nominal* equalities (a ~N ty) that are not+immediately soluble by unification.++More specifically, here's how it works (Oct 16):++* Wanted constraints are born as [WD]; this behaves like a+  [W] and a [D] paired together.++* When we are about to add a [WD] to the inert set, if it can+  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],+  putting the latter into the work list (see maybeEmitShadow).++In the example above, we get to the point where we are stuck:+    [WD] Foo ee ~ Foo e+    [WD] Foo ee ~ Maybe ee++But now when [WD] Foo ee ~ Maybe ee is about to be added, we'll+split it into [W] and [D], since the inert [WD] Foo ee ~ Foo e+can rewrite it.  Then:+    work item: [D] Foo ee ~ Maybe ee+    inert:     [W] Foo ee ~ Maybe ee+               [WD] Foo ee ~ Maybe e++See Note [Splitting WD constraints].  Now the work item is rewritten+by the [WD] and we soon get ee := e.++Additional notes:++  * The derived shadow equalities live in inert_eqs, along with+    the Givens and Wanteds; see Note [EqualCtList invariants]+    in GHC.Tc.Solver.Types.++  * We make Derived shadows only for Wanteds, not Givens.  So we+    have only [G], not [GD] and [G] plus splitting.  See+    Note [Add derived shadows only for Wanteds]++  * We also get Derived equalities from functional dependencies+    and type-function injectivity; see calls to unifyDerived.++  * It's worth having [WD] rather than just [W] and [D] because+    * efficiency: silly to process the same thing twice+    * inert_dicts is a finite map keyed by+      the type; it's inconvenient for it to map to TWO constraints++Another example requiring Deriveds is in+Note [Put touchable variables on the left] in GHC.Tc.Solver.Canonical.++Note [Splitting WD constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are about to add a [WD] constraint to the inert set; and we+know that the inert set has fully rewritten it.  Should we split+it into [W] and [D], and put the [D] in the work list for further+work?++* CDictCan (C tys):+  Yes if the inert set could rewrite tys to make the class constraint,+  or type family, fire.  That is, yes if the inert_eqs intersects+  with the free vars of tys.  For this test we use+  (anyRewritableTyVar True) which ignores casts and coercions in tys,+  because rewriting the casts or coercions won't make the thing fire+  more often.++* CEqCan (lhs ~ ty): Yes if the inert set could rewrite 'lhs' or 'ty'.+  We need to check both 'lhs' and 'ty' against the inert set:+    - Inert set contains  [D] a ~ ty2+      Then we want to put [D] a ~ ty in the worklist, so we'll+      get [D] ty ~ ty2 with consequent good things++    - Inert set contains [D] b ~ a, where b is in ty.+      We can't just add [WD] a ~ ty[b] to the inert set, because+      that breaks the inert-set invariants.  If we tried to+      canonicalise another [D] constraint mentioning 'a', we'd+      get an infinite loop++  Moreover we must use (anyRewritableTyVar False) for the RHS,+  because even tyvars in the casts and coercions could give+  an infinite loop if we don't expose it++* CIrredCan: Yes if the inert set can rewrite the constraint.+  We used to think splitting irreds was unnecessary, but+  see Note [Splitting Irred WD constraints]++* Others: nothing is gained by splitting.++Note [Splitting Irred WD constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Splitting Irred constraints can make a difference. Here is the+scenario:++  a[sk] :: F v     -- F is a type family+  beta :: alpha++  work item: [WD] a ~ beta++This is heterogeneous, so we emit a kind equality and make the work item an+inert Irred.++  work item: [D] F v ~ alpha+  inert: [WD] (a |> co) ~ beta (CIrredCan)++Can't make progress on the work item. Add to inert set. This kicks out the+old inert, because a [D] can rewrite a [WD].++  work item: [WD] (a |> co) ~ beta+  inert: [D] F v ~ alpha (CEqCan)++Can't make progress on this work item either (although GHC tries by+decomposing the cast and rewriting... but that doesn't make a difference),+which is still hetero. Emit a new kind equality and add to inert set. But,+critically, we split the Irred.++  work list:+   [D] F v ~ alpha (CEqCan)+   [D] (a |> co) ~ beta (CIrred) -- this one was split off+  inert:+   [W] (a |> co) ~ beta+   [D] F v ~ alpha++We quickly solve the first work item, as it's the same as an inert.++  work item: [D] (a |> co) ~ beta+  inert:+   [W] (a |> co) ~ beta+   [D] F v ~ alpha++We decompose the cast, yielding++  [D] a ~ beta++We then rewrite the kinds. The lhs kind is F v, which flattens to alpha.++  co' :: F v ~ alpha+  [D] (a |> co') ~ beta++Now this equality is homo-kinded. So we swizzle it around to++  [D] beta ~ (a |> co')++and set beta := a |> co', and go home happy.++If we don't split the Irreds, we loop. This is all dangerously subtle.++This is triggered by test case typecheck/should_compile/SplitWD.++Note [Add derived shadows only for Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only add shadows for Wanted constraints. That is, we have+[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]+constraints.++It does just possibly make sense ot add a derived shadow for a+Given. If we created a Derived shadow of a Given, it could be+rewritten by other Deriveds, and that could, conceivably, lead to a+useful unification.++But (a) I have been unable to come up with an example of this+        happening+    (b) see #12660 for how adding the derived shadows+        of a Given led to an infinite loop.+    (c) It's unlikely that rewriting derived Givens will lead+        to a unification because Givens don't mention touchable+        unification variables++For (b) there may be other ways to solve the loop, but simply+reraining from adding derived shadows of Givens is particularly+simple.  And it's more efficient too!++Still, here's one possible reason for adding derived shadows+for Givens.  Consider+           work-item [G] a ~ [b], inerts has [D] b ~ a.+If we added the derived shadow (into the work list)+         [D] a ~ [b]+When we process it, we'll rewrite to a ~ [a] and get an+occurs check.  Without it we'll miss the occurs check (reporting+inaccessible code); but that's probably OK.++Note [Keep CDictCan shadows as CDictCan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  class C a => D a b+and [G] D a b, [G] C a in the inert set.  Now we insert+[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,+so we can rewrite it with the new constraint, and perhaps get+instance reduction or other consequences.++BUT we do not want to kick out a *non-canonical* (D a b). If we+did, we would do this:+  - rewrite it to [D] D a c, with pend_sc = True+  - use expandSuperClasses to add C a+  - go round again, which solves C a from the givens+This loop goes on for ever and triggers the simpl_loop limit.++Solution: kick out the CDictCan which will have pend_sc = False,+because we've already added its superclasses.  So we won't re-add+them.  If we forget the pend_sc flag, our cunning scheme for avoiding+generating superclasses repeatedly will fail.++See #11379 for a case of this.++Note [Do not do improvement for WOnly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do improvement between two constraints (e.g. for injectivity+or functional dependencies) only if both are "improvable". And+we improve a constraint wrt the top-level instances only if+it is improvable.++Improvable:     [G] [WD] [D}+Not improvable: [W]++Reasons:++* It's less work: fewer pairs to compare++* Every [W] has a shadow [D] so nothing is lost++* Consider [WD] C Int b,  where 'b' is a skolem, and+    class C a b | a -> b+    instance C Int Bool+  We'll do a fundep on it and emit [D] b ~ Bool+  That will kick out constraint [WD] C Int b+  Then we'll split it to [W] C Int b (keep in inert)+                     and [D] C Int b (in work list)+  When processing the latter we'll rewrite it to+        [D] C Int Bool+  At that point it would be /stupid/ to interact it+  with the inert [W] C Int b in the inert set; after all,+  it's the very constraint from which the [D] C Int Bool+  was split!  We can avoid this by not doing improvement+  on [W] constraints. This came up in #12860.+-}++maybeEmitShadow :: InertCans -> Ct -> TcS Ct+-- See Note [The improvement story and derived shadows]+maybeEmitShadow ics ct+  | let ev = ctEvidence ct+  , CtWanted { ctev_pred = pred, ctev_loc = loc+             , ctev_nosh = WDeriv } <- ev+  , shouldSplitWD (inert_eqs ics) (inert_funeqs ics) ct+  = do { traceTcS "Emit derived shadow" (ppr ct)+       ; let derived_ev = CtDerived { ctev_pred = pred+                                    , ctev_loc  = loc }+             shadow_ct = ct { cc_ev = derived_ev }+               -- Te shadow constraint keeps the canonical shape.+               -- This just saves work, but is sometimes important;+               -- see Note [Keep CDictCan shadows as CDictCan]+       ; emitWork [shadow_ct]++       ; let ev' = ev { ctev_nosh = WOnly }+             ct' = ct { cc_ev = ev' }+                 -- Record that it now has a shadow+                 -- This is /the/ place we set the flag to WOnly+       ; return ct' }++  | otherwise+  = return ct++shouldSplitWD :: InertEqs -> FunEqMap EqualCtList -> Ct -> Bool+-- Precondition: 'ct' is [WD], and is inert+-- True <=> we should split ct ito [W] and [D] because+--          the inert_eqs can make progress on the [D]+-- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs fun_eqs (CDictCan { cc_tyargs = tys })+  = should_split_match_args inert_eqs fun_eqs tys+    -- NB True: ignore coercions+    -- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty+                                        , cc_eq_rel = eq_rel })+  =  tv `elemDVarEnv` inert_eqs+  || anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) ty+  -- NB False: do not ignore casts and coercions+  -- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })+  = anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)+                          (ctEvPred ev)++shouldSplitWD inert_eqs fun_eqs (CIrredCan { cc_ev = ev })+  = anyRewritableCanEqLHS (ctEvEqRel ev) (canRewriteTv inert_eqs)+                          (canRewriteTyFam fun_eqs) (ctEvPred ev)++shouldSplitWD _ _ _ = False   -- No point in splitting otherwise++should_split_match_args :: InertEqs -> FunEqMap EqualCtList -> [TcType] -> Bool+-- True if the inert_eqs can rewrite anything in the argument types+should_split_match_args inert_eqs fun_eqs tys+  = any (anyRewritableCanEqLHS NomEq (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)) tys+    -- See Note [Splitting WD constraints]++canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool+canRewriteTv inert_eqs eq_rel tv+  | Just (EqualCtList (ct :| _)) <- lookupDVarEnv inert_eqs tv+  , CEqCan { cc_eq_rel = eq_rel1 } <- ct+  = eq_rel1 `eqCanRewrite` eq_rel+  | otherwise+  = False++canRewriteTyFam :: FunEqMap EqualCtList -> EqRel -> TyCon -> [Type] -> Bool+canRewriteTyFam fun_eqs eq_rel tf args+  | Just (EqualCtList (ct :| _)) <- findFunEq fun_eqs tf args+  , CEqCan { cc_eq_rel = eq_rel1 } <- ct+  = eq_rel1 `eqCanRewrite` eq_rel+  | otherwise+  = False++isImprovable :: CtEvidence -> Bool+-- See Note [Do not do improvement for WOnly]+isImprovable (CtWanted { ctev_nosh = WOnly }) = False+isImprovable _                                = True+++{- *********************************************************************+*                                                                      *+                   Inert instances: inert_insts+*                                                                      *+********************************************************************* -}++addInertForAll :: QCInst -> TcS ()+-- Add a local Given instance, typically arising from a type signature+addInertForAll new_qci+  = do { ics  <- getInertCans+       ; ics1 <- add_qci ics++       -- Update given equalities. C.f updateGivenEqs+       ; tclvl <- getTcLevel+       ; let pred         = qci_pred new_qci+             not_equality = isClassPred pred && not (isEqPred pred)+                  -- True <=> definitely not an equality+                  -- A qci_pred like (f a) might be an equality++             ics2 | not_equality = ics1+                  | otherwise    = ics1 { inert_given_eq_lvl = tclvl+                                        , inert_given_eqs    = True }++       ; setInertCans ics2 }+  where+    add_qci :: InertCans -> TcS InertCans+    -- See Note [Do not add duplicate quantified instances]+    add_qci ics@(IC { inert_insts = qcis })+      | any same_qci qcis+      = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci)+           ; return ics }++      | otherwise+      = do { traceTcS "adding new inert quantified instance" (ppr new_qci)+           ; return (ics { inert_insts = new_qci : qcis }) }++    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))+                                (ctEvPred (qci_ev new_qci))++{- Note [Do not add duplicate quantified instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#15244):++  f :: (C g, D g) => ....+  class S g => C g where ...+  class S g => D g where ...+  class (forall a. Eq a => Eq (g a)) => S g where ...++Then in f's RHS there are two identical quantified constraints+available, one via the superclasses of C and one via the superclasses+of D.  The two are identical, and it seems wrong to reject the program+because of that. But without doing duplicate-elimination we will have+two matching QCInsts when we try to solve constraints arising from f's+RHS.++The simplest thing is simply to eliminate duplicates, which we do here.+-}++{- *********************************************************************+*                                                                      *+                  Adding an inert+*                                                                      *+************************************************************************++Note [Adding an equality to the InertCans]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When adding an equality to the inerts:++* Split [WD] into [W] and [D] if the inerts can rewrite the latter;+  done by maybeEmitShadow.++* Kick out any constraints that can be rewritten by the thing+  we are adding.  Done by kickOutRewritable.++* Note that unifying a:=ty, is like adding [G] a~ty; just use+  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.+-}++addInertCan :: Ct -> TcS ()+-- Precondition: item /is/ canonical+-- See Note [Adding an equality to the InertCans]+addInertCan ct+  = do { traceTcS "addInertCan {" $+         text "Trying to insert new inert item:" <+> ppr ct++       ; ics <- getInertCans+       ; ct  <- maybeEmitShadow ics ct+       ; ics <- maybeKickOut ics ct+       ; tclvl <- getTcLevel+       ; setInertCans (addInertItem tclvl ics ct)++       ; traceTcS "addInertCan }" $ empty }++maybeKickOut :: InertCans -> Ct -> TcS InertCans+-- For a CEqCan, kick out any inert that can be rewritten by the CEqCan+maybeKickOut ics ct+  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct+  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics+       ; return ics' }+  | otherwise+  = return ics++-----------------------------------------+kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that+                                      -- is being added to the inert set+                   -> CanEqLHS        -- The new equality is lhs ~ ty+                   -> InertCans+                   -> TcS (Int, InertCans)+kickOutRewritable new_fr new_lhs ics+  = do { let (kicked_out, ics') = kickOutRewritableLHS new_fr new_lhs ics+             n_kicked = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)++              -- The famapp-cache contains Given evidence from the inert set.+              -- If we're kicking out Givens, we need to remove this evidence+              -- from the cache, too.+            ; let kicked_given_ev_vars =+                    [ ev_var | ct <- wl_eqs kicked_out+                             , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]+            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&+                   -- if this isn't true, no use looking through the constraints+                    not (null kicked_given_ev_vars)) $+              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"+                            (ppr kicked_given_ev_vars)+                 ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }++            ; csTraceTcS $+              hang (text "Kick out, lhs =" <+> ppr new_lhs)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; return (n_kicked, ics') }++kickOutAfterUnification :: TcTyVar -> TcS Int+kickOutAfterUnification new_tv+  = do { ics <- getInertCans+       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)+                                                 (TyVarLHS new_tv) ics+                     -- Given because the tv := xi is given; NomEq because+                     -- only nominal equalities are solved by unification++       ; setInertCans ics2+       ; return n_kicked }++-- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS ()+kickOutAfterFillingCoercionHole hole filled_co+  = do { ics <- getInertCans+       ; let (kicked_out, ics') = kick_out ics+             n_kicked           = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)+            ; csTraceTcS $+              hang (text "Kick out, hole =" <+> ppr hole)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; setInertCans ics' }+  where+    holes_of_co = coercionHolesOfCo filled_co++    kick_out :: InertCans -> (WorkList, InertCans)+    kick_out ics@(IC { inert_irreds = irreds })+      = let (to_kick, to_keep) = partitionBagWith kick_ct irreds++            kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList+            ics'       = ics { inert_irreds = to_keep }+        in+        (kicked_out, ics')++    kick_ct :: Ct -> Either Ct Ct+         -- Left: kick out; Right: keep. But even if we keep, we may need+         -- to update the set of blocking holes+    kick_ct ct@(CIrredCan { cc_status = BlockedCIS holes })+      | hole `elementOfUniqSet` holes+      = let new_holes = holes `delOneFromUniqSet` hole+                              `unionUniqSets` holes_of_co+            updated_ct = ct { cc_status = BlockedCIS new_holes }+        in+        if isEmptyUniqSet new_holes+        then Left updated_ct+        else Right updated_ct+    kick_ct other = Right other++--------------+addInertSafehask :: InertCans -> Ct -> InertCans+addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })+  = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item }++addInertSafehask _ item+  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item++insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+insertSafeOverlapFailureTcS what item+  | safeOverlap what = return ()+  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)++getSafeOverlapFailures :: TcS Cts+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+getSafeOverlapFailures+ = do { IC { inert_safehask = safehask } <- getInertCans+      ; return $ foldDicts consCts safehask emptyCts }++--------------+addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()+-- Conditionally add a new item in the solved set of the monad+-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet+addSolvedDict what item cls tys+  | isWanted item+  , instanceReturnsDictCon what+  = do { traceTcS "updSolvedSetTcs:" $ ppr item+       ; updInertTcS $ \ ics ->+             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }+  | otherwise+  = return ()++getSolvedDicts :: TcS (DictMap CtEvidence)+getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }++setSolvedDicts :: DictMap CtEvidence -> TcS ()+setSolvedDicts solved_dicts+  = updInertTcS $ \ ics ->+    ics { inert_solved_dicts = solved_dicts }+++{- *********************************************************************+*                                                                      *+                  Other inert-set operations+*                                                                      *+********************************************************************* -}++updInertTcS :: (InertSet -> InertSet) -> TcS ()+-- Modify the inert set with the supplied function+updInertTcS upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }++getInertCans :: TcS InertCans+getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }++setInertCans :: InertCans -> TcS ()+setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }++updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a+-- Modify the inert set with the supplied function+updRetInertCans upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { inerts <- TcM.readTcRef is_var+                     ; let (res, cans') = upd_fn (inert_cans inerts)+                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })+                     ; return res }) }++updInertCans :: (InertCans -> InertCans) -> TcS ()+-- Modify the inert set with the supplied function+updInertCans upd_fn+  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }++updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertDicts upd_fn+  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }++updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertSafehask upd_fn+  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }++updInertIrreds :: (Cts -> Cts) -> TcS ()+-- Modify the inert set with the supplied function+updInertIrreds upd_fn+  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }++getInertEqs :: TcS (DTyVarEnv EqualCtList)+getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }++getInnermostGivenEqLevel :: TcS TcLevel+getInnermostGivenEqLevel = do { inert <- getInertCans+                              ; return (inert_given_eq_lvl inert) }++getInertInsols :: TcS Cts+-- Returns insoluble equality constraints+-- specifically including Givens+getInertInsols = do { inert <- getInertCans+                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }++getInertGivens :: TcS [Ct]+-- Returns the Given constraints in the inert set+getInertGivens+  = do { inerts <- getInertCans+       ; let all_cts = foldDicts (:) (inert_dicts inerts)+                     $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out)+                                  (inert_funeqs inerts)+                     $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts))+       ; return (filter isGivenCt all_cts) }++getPendingGivenScs :: TcS [Ct]+-- Find all inert Given dictionaries, or quantified constraints,+--     whose cc_pend_sc flag is True+--     and that belong to the current level+-- Set their cc_pend_sc flag to False in the inert set, and return that Ct+getPendingGivenScs = do { lvl <- getTcLevel+                        ; updRetInertCans (get_sc_pending lvl) }++get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)+get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })+  = assertPpr (all isGivenCt sc_pending) (ppr sc_pending)+       -- When getPendingScDics is called,+       -- there are never any Wanteds in the inert set+    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })+  where+    sc_pending = sc_pend_insts ++ sc_pend_dicts++    sc_pend_dicts = foldDicts get_pending dicts []+    dicts' = foldr add dicts sc_pend_dicts++    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts++    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True+                                       -- but flipping the flag+    get_pending dict dicts+        | Just dict' <- isPendingScDict dict+        , belongs_to_this_level (ctEvidence dict)+        = dict' : dicts+        | otherwise+        = dicts++    add :: Ct -> DictMap Ct -> DictMap Ct+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts+        = addDictCt dicts cls tys ct+    add ct _ = pprPanic "getPendingScDicts" (ppr ct)++    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)+    get_pending_inst cts qci@(QCI { qci_ev = ev })+       | Just qci' <- isPendingScInst qci+       , belongs_to_this_level ev+       = (CQuantCan qci' : cts, qci')+       | otherwise+       = (cts, qci)++    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl+    -- We only want Givens from this level; see (3a) in+    -- Note [The superclass story] in GHC.Tc.Solver.Canonical++getUnsolvedInerts :: TcS ( Bag Implication+                         , Cts )   -- All simple constraints+-- Return all the unsolved [Wanted] or [Derived] constraints+--+-- Post-condition: the returned simple constraints are all fully zonked+--                     (because they come from the inert set)+--                 the unsolved implics may not be+getUnsolvedInerts+ = do { IC { inert_eqs    = tv_eqs+           , inert_funeqs = fun_eqs+           , inert_irreds = irreds+           , inert_dicts  = idicts+           } <- getInertCans++      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts+            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts+            unsolved_irreds  = Bag.filterBag is_unsolved irreds+            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts+            unsolved_others  = unsolved_irreds `unionBags` unsolved_dicts++      ; implics <- getWorkListImplics++      ; traceTcS "getUnsolvedInerts" $+        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs+             , text "fun eqs =" <+> ppr unsolved_fun_eqs+             , text "others =" <+> ppr unsolved_others+             , text "implics =" <+> ppr implics ]++      ; return ( implics, unsolved_tv_eqs `unionBags`+                          unsolved_fun_eqs `unionBags`+                          unsolved_others) }+  where+    add_if_unsolved :: Ct -> Cts -> Cts+    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts+                           | otherwise      = cts++    add_if_unsolveds :: EqualCtList -> Cts -> Cts+    add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts+                                             (equalCtListToList new_cts)++    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived++getHasGivenEqs :: TcLevel           -- TcLevel of this implication+               -> TcS ( HasGivenEqs -- are there Given equalities?+                      , Cts )       -- Insoluble equalities arising from givens+-- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet+getHasGivenEqs tclvl+  = do { inerts@(IC { inert_irreds       = irreds+                    , inert_given_eqs    = given_eqs+                    , inert_given_eq_lvl = ge_lvl })+              <- getInertCans+       ; let insols = filterBag insolubleEqCt irreds+                      -- Specifically includes ones that originated in some+                      -- outer context but were refined to an insoluble by+                      -- a local equality; so do /not/ add ct_given_here.++             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and+             -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet+             has_ge | ge_lvl == tclvl = MaybeGivenEqs+                    | given_eqs       = LocalGivenEqs+                    | otherwise       = NoGivenEqs++       ; traceTcS "getHasGivenEqs" $+         vcat [ text "given_eqs:" <+> ppr given_eqs+              , text "ge_lvl:" <+> ppr ge_lvl+              , text "ambient level:" <+> ppr tclvl+              , text "Inerts:" <+> ppr inerts+              , text "Insols:" <+> ppr insols]+       ; return (has_ge, insols) }++{- Note [Unsolved Derived equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In getUnsolvedInerts, we return a derived equality from the inert_eqs+because it is a candidate for floating out of this implication.  We+only float equalities with a meta-tyvar on the left, so we only pull+those out here.++Note [What might equal later?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must determine whether a Given might later equal a Wanted. We+definitely need to account for the possibility that any metavariable+might be arbitrarily instantiated. Yet we do *not* want+to allow skolems in to be instantiated, as we've already rewritten+with respect to any Givens. (We're solving a Wanted here, and so+all Givens have already been processed.)++This is best understood by example.++1. C alpha  ~?  C Int++   That given certainly might match later.++2. C a  ~?  C Int++   No. No new givens are going to arise that will get the `a` to rewrite+   to Int.++3. C alpha[tv]   ~?  C Int++   That alpha[tv] is a TyVarTv, unifiable only with other type variables.+   It cannot equal later.++4. C (F alpha)   ~?   C Int++   Sure -- that can equal later, if we learn something useful about alpha.++5. C (F alpha[tv])  ~?  C Int++   This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere.+   Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other,+   and F x x = Int. Remember: returning True doesn't commit ourselves to+   anything.++6. C (F a)  ~?  C a++   No, this won't match later. If we could rewrite (F a) or a, we would+   have by now.++7. C (Maybe alpha)  ~?  C alpha++   We say this cannot equal later, because it would require+   alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived,+   we choose not to worry about it. See Note [Infinitary substitution in lookup]+   in GHC.Core.InstEnv. Getting this wrong let to #19107, tested in+   typecheck/should_compile/T19107.++8. C cbv   ~?  C Int+   where cbv = F a++   The cbv is a cycle-breaker var which stands for F a. See+   Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical.+   This is just like case 6, and we say "no". Saying "no" here is+   essential in getting the parser to type-check, with its use of DisambECP.++9. C cbv   ~?   C Int+   where cbv = F alpha++   Here, we might indeed equal later. Distinguishing between+   this case and Example 8 is why we need the InertSet in mightEqualLater.++10. C (F alpha, Int)  ~?  C (Bool, F alpha)++   This cannot equal later, because F a would have to equal both Bool and+   Int.++To deal with type family applications, we use the Core flattener. See+Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.+The Core flattener replaces all type family applications with+fresh variables. The next question: should we allow these fresh+variables in the domain of a unifying substitution?++A type family application that mentions only skolems (example 6) is settled:+any skolems would have been rewritten w.r.t. Givens by now. These type family+applications match only themselves. A type family application that mentions+metavariables, on the other hand, can match anything. So, if the original type+family application contains a metavariable, we use BindMe to tell the unifier+to allow it in the substitution. On the other hand, a type family application+with only skolems is considered rigid.++This treatment fixes #18910 and is tested in+typecheck/should_compile/InstanceGivenOverlap{,2}+-}++removeInertCts :: [Ct] -> InertCans -> InertCans+-- ^ Remove inert constraints from the 'InertCans', for use when a+-- typechecker plugin wishes to discard a given.+removeInertCts cts icans = foldl' removeInertCt icans cts++removeInertCt :: InertCans -> Ct -> InertCans+removeInertCt is ct =+  case ct of++    CDictCan  { cc_class = cl, cc_tyargs = tys } ->+      is { inert_dicts = delDict (inert_dicts is) cl tys }++    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs++    CQuantCan {}     -> panic "removeInertCt: CQuantCan"+    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"+    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"++-- | Looks up a family application in the inerts; returned coercion+-- is oriented input ~ output+lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavourRole))+lookupFamAppInert fam_tc tys+  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts+       ; return (lookup_inerts inert_funeqs) }+  where+    lookup_inerts inert_funeqs+      | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _))+          <- findFunEq inert_funeqs fam_tc tys+      = Just (ctEvCoercion ctev, rhs, ctEvFlavourRole ctev)+      | otherwise = Nothing++lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)+-- Is this exact predicate type cached in the solved or canonicals of the InertSet?+lookupInInerts loc pty+  | ClassPred cls tys <- classifyPredType pty+  = do { inerts <- getTcSInerts+       ; return (lookupSolvedDict inerts loc cls tys `mplus`+                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }+  | otherwise -- NB: No caching for equalities, IPs, holes, or errors+  = return Nothing++-- | Look up a dictionary inert.+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct+lookupInertDict (IC { inert_dicts = dicts }) loc cls tys+  = case findDict dicts loc cls tys of+      Just ct -> Just ct+      _       -> Nothing++-- | Look up a solved inert.+lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence+-- Returns just if exactly this predicate type exists in the solved.+lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys+  = case findDict solved loc cls tys of+      Just ev -> Just ev+      _       -> Nothing++---------------------------+lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))+lookupFamAppCache fam_tc tys+  = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts+       ; case findFunEq famapp_cache fam_tc tys of+           result@(Just (co, ty)) ->+             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)+                                                    , ppr ty+                                                    , ppr co ])+                ; return result }+           Nothing -> return Nothing }++extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()+-- NB: co :: rhs ~ F tys, to match expectations of rewriter+extendFamAppCache tc xi_args stuff@(_, ty)+  = do { dflags <- getDynFlags+       ; when (gopt Opt_FamAppCache dflags) $+    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args+                                            , ppr ty ])+            -- 'co' can be bottom, in the case of derived items+       ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->+            is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }++-- Remove entries from the cache whose evidence mentions variables in the+-- supplied set+dropFromFamAppCache :: VarSet -> TcS ()+dropFromFamAppCache varset+  = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts+       ; let filtered = filterTcAppMap check famapp_cache+       ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }+  where+    check :: (TcCoercion, TcType) -> Bool+    check (co, _) = not (anyFreeVarsOfCo (`elemVarSet` varset) co)++{- *********************************************************************+*                                                                      *+                   Irreds+*                                                                      *+********************************************************************* -}++foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b+foldIrreds k irreds z = foldr k z irreds++{-+************************************************************************+*                                                                      *+*              The TcS solver monad                                    *+*                                                                      *+************************************************************************++Note [The TcS monad]+~~~~~~~~~~~~~~~~~~~~+The TcS monad is a weak form of the main Tc monad++All you can do is+    * fail+    * allocate new variables+    * fill in evidence variables++Filling in a dictionary evidence variable means to create a binding+for it, so TcS carries a mutable location where the binding can be+added.  This is initialised from the innermost implication constraint.+-}++data TcSEnv+  = TcSEnv {+      tcs_ev_binds    :: EvBindsVar,++      tcs_unified     :: IORef Int,+         -- The number of unification variables we have filled+         -- The important thing is whether it is non-zero++      tcs_unif_lvl  :: IORef (Maybe TcLevel),+         -- The Unification Level Flag+         -- Outermost level at which we have unified a meta tyvar+         -- Starts at Nothing, then (Just i), then (Just j) where j<i+         -- See Note [The Unification Level Flag]++      tcs_count     :: IORef Int, -- Global step count++      tcs_inerts    :: IORef InertSet, -- Current inert set++      -- See Note [WorkList priorities] in GHC.Tc.Solver.InertSet+      tcs_worklist  :: IORef WorkList -- Current worklist+    }++---------------+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)++-- | Smart constructor for 'TcS', as describe in Note [The one-shot state+-- monad trick] in "GHC.Utils.Monad".+mkTcS :: (TcSEnv -> TcM a) -> TcS a+mkTcS f = TcS (oneShot f)++instance Applicative TcS where+  pure x = mkTcS $ \_ -> return x+  (<*>) = ap++instance Monad TcS where+  m >>= k   = mkTcS $ \ebs -> do+    unTcS m ebs >>= (\r -> unTcS (k r) ebs)++instance MonadFail TcS where+  fail err  = mkTcS $ \_ -> fail err++instance MonadUnique TcS where+   getUniqueSupplyM = wrapTcS getUniqueSupplyM++instance HasModule TcS where+   getModule = wrapTcS getModule++instance MonadThings TcS where+   lookupThing n = wrapTcS (lookupThing n)++-- Basic functionality+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+wrapTcS :: TcM a -> TcS a+-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,+-- and TcS is supposed to have limited functionality+wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds++wrapErrTcS :: TcM a -> TcS a+-- The thing wrapped should just fail+-- There's no static check; it's up to the user+-- Having a variant for each error message is too painful+wrapErrTcS = wrapTcS++wrapWarnTcS :: TcM a -> TcS a+-- The thing wrapped should just add a warning, or no-op+-- There's no static check; it's up to the user+wrapWarnTcS = wrapTcS++failTcS, panicTcS  :: SDoc -> TcS a+warnTcS   :: WarningFlag -> SDoc -> TcS ()+addErrTcS :: SDoc -> TcS ()+failTcS      = wrapTcS . TcM.failWith+warnTcS flag = wrapTcS . TcM.addDiagnostic (WarningWithFlag flag)+addErrTcS    = wrapTcS . TcM.addErr+panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc++traceTcS :: String -> SDoc -> TcS ()+traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)+{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]++runTcPluginTcS :: TcPluginM a -> TcS a+runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar++instance HasDynFlags TcS where+    getDynFlags = wrapTcS getDynFlags++getGlobalRdrEnvTcS :: TcS GlobalRdrEnv+getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv++bumpStepCountTcS :: TcS ()+bumpStepCountTcS = mkTcS $ \env ->+  do { let ref = tcs_count env+     ; n <- TcM.readTcRef ref+     ; TcM.writeTcRef ref (n+1) }++csTraceTcS :: SDoc -> TcS ()+csTraceTcS doc+  = wrapTcS $ csTraceTcM (return doc)+{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]++traceFireTcS :: CtEvidence -> SDoc -> TcS ()+-- Dump a rule-firing trace+traceFireTcS ev doc+  = mkTcS $ \env -> csTraceTcM $+    do { n <- TcM.readTcRef (tcs_count env)+       ; tclvl <- TcM.getTcLevel+       ; return (hang (text "Step" <+> int n+                       <> brackets (text "l:" <> ppr tclvl <> comma <>+                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))+                       <+> doc <> colon)+                     4 (ppr ev)) }+{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]++csTraceTcM :: TcM SDoc -> TcM ()+-- Constraint-solver tracing, -ddump-cs-trace+csTraceTcM mk_doc+  = do { dflags <- getDynFlags+       ; when (  dopt Opt_D_dump_cs_trace dflags+                  || dopt Opt_D_dump_tc_trace dflags )+              ( do { msg <- mk_doc+                   ; TcM.dumpTcRn False+                       Opt_D_dump_cs_trace+                       "" FormatText+                       msg }) }+{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]++runTcS :: TcS a                -- What to run+       -> TcM (a, EvBindMap)+runTcS tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; res <- runTcSWithEvBinds ev_binds_var tcs+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; return (res, ev_binds) }+-- | This variant of 'runTcS' will keep solving, even when only Deriveds+-- are left around. It also doesn't return any evidence, as callers won't+-- need it.+runTcSDeriveds :: TcS a -> TcM a+runTcSDeriveds tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; runTcSWithEvBinds ev_binds_var tcs }++-- | This can deal only with equality constraints.+runTcSEqualities :: TcS a -> TcM a+runTcSEqualities thing_inside+  = do { ev_binds_var <- TcM.newNoTcEvBinds+       ; runTcSWithEvBinds ev_binds_var thing_inside }++-- | A variant of 'runTcS' that takes and returns an 'InertSet' for+-- later resumption of the 'TcS' session.+runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)+runTcSInerts inerts tcs = do+  ev_binds_var <- TcM.newTcEvBinds+  runTcSWithEvBinds' False ev_binds_var $ do+    setTcSInerts inerts+    a <- tcs+    new_inerts <- getTcSInerts+    return (a, new_inerts)++runTcSWithEvBinds :: EvBindsVar+                  -> TcS a+                  -> TcM a+runTcSWithEvBinds = runTcSWithEvBinds' True++runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?+                           -- Don't if you want to reuse the InertSet.+                           -- See also Note [Type variable cycles in Givens]+                           -- in GHC.Tc.Solver.Canonical+                   -> EvBindsVar+                   -> TcS a+                   -> TcM a+runTcSWithEvBinds' restore_cycles ev_binds_var tcs+  = do { unified_var <- TcM.newTcRef 0+       ; step_count <- TcM.newTcRef 0+       ; inert_var <- TcM.newTcRef emptyInert+       ; wl_var <- TcM.newTcRef emptyWorkList+       ; unif_lvl_var <- TcM.newTcRef Nothing+       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var+                          , tcs_unified       = unified_var+                          , tcs_unif_lvl      = unif_lvl_var+                          , tcs_count         = step_count+                          , tcs_inerts        = inert_var+                          , tcs_worklist      = wl_var }++             -- Run the computation+       ; res <- unTcS tcs env++       ; count <- TcM.readTcRef step_count+       ; when (count > 0) $+         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)++       ; when restore_cycles $+         do { inert_set <- TcM.readTcRef inert_var+            ; restoreTyVarCycles inert_set }++#if defined(DEBUG)+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; checkForCyclicBinds ev_binds+#endif++       ; return res }++----------------------------+#if defined(DEBUG)+checkForCyclicBinds :: EvBindMap -> TcM ()+checkForCyclicBinds ev_binds_map+  | null cycles+  = return ()+  | null coercion_cycles+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles+  | otherwise+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles+  where+    ev_binds = evBindMapBinds ev_binds_map++    cycles :: [[EvBind]]+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]++    coercion_cycles = [c | c <- cycles, any is_co_bind c]+    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)++    edges :: [ Node EvVar EvBind ]+    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))+            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]+            -- It's OK to use nonDetEltsUFM here as+            -- stronglyConnCompFromEdgedVertices is still deterministic even+            -- if the edges are in nondeterministic order as explained in+            -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.+#endif++----------------------------+setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a+setEvBindsTcS ref (TcS thing_inside)+ = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })++nestImplicTcS :: EvBindsVar+              -> TcLevel -> TcS a+              -> TcS a+nestImplicTcS ref inner_tclvl (TcS thing_inside)+  = TcS $ \ TcSEnv { tcs_unified       = unified_var+                   , tcs_inerts        = old_inert_var+                   , tcs_count         = count+                   , tcs_unif_lvl      = unif_lvl+                   } ->+    do { inerts <- TcM.readTcRef old_inert_var+       ; let nest_inert = inerts { inert_cycle_breakers = []+                                 , inert_cans = (inert_cans inerts)+                                                   { inert_given_eqs = False } }+                 -- All other InertSet fields are inherited+       ; new_inert_var <- TcM.newTcRef nest_inert+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = TcSEnv { tcs_count         = count     -- Inherited+                               , tcs_unif_lvl      = unif_lvl  -- Inherited+                               , tcs_ev_binds      = ref+                               , tcs_unified       = unified_var+                               , tcs_inerts        = new_inert_var+                               , tcs_worklist      = new_wl_var }+       ; res <- TcM.setTcLevel inner_tclvl $+                thing_inside nest_env++       ; out_inert_set <- TcM.readTcRef new_inert_var+       ; restoreTyVarCycles out_inert_set++#if defined(DEBUG)+       -- Perform a check that the thing_inside did not cause cycles+       ; ev_binds <- TcM.getTcEvBindsMap ref+       ; checkForCyclicBinds ev_binds+#endif+       ; return res }++nestTcS ::  TcS a -> TcS a+-- Use the current untouchables, augmenting the current+-- evidence bindings, and solved dictionaries+-- But have no effect on the InertCans, or on the inert_famapp_cache+-- (we want to inherit the latter from processing the Givens)+nestTcS (TcS thing_inside)+  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->+    do { inerts <- TcM.readTcRef inerts_var+       ; new_inert_var <- TcM.newTcRef inerts+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = env { tcs_inerts   = new_inert_var+                            , tcs_worklist = new_wl_var }++       ; res <- thing_inside nest_env++       ; new_inerts <- TcM.readTcRef new_inert_var++       -- we want to propagate the safe haskell failures+       ; let old_ic = inert_cans inerts+             new_ic = inert_cans new_inerts+             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }++       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]+                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts+                                , inert_cans = nxt_ic })++       ; return res }++emitImplicationTcS :: TcLevel -> SkolemInfo+                   -> [TcTyVar]        -- Skolems+                   -> [EvVar]          -- Givens+                   -> Cts              -- Wanteds+                   -> TcS TcEvBinds+-- Add an implication to the TcS monad work-list+emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_given  = givens+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) }++       ; emitImplication imp+       ; return (TcEvBinds (ic_binds imp)) }++emitTvImplicationTcS :: TcLevel -> SkolemInfo+                     -> [TcTyVar]        -- Skolems+                     -> Cts              -- Wanteds+                     -> TcS ()+-- Just like emitImplicationTcS but no givens and no bindings+emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newNoTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) }++       ; emitImplication imp }+++{- Note [Propagate the solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really quite important that nestTcS does not discard the solved+dictionaries from the thing_inside.+Consider+   Eq [a]+   forall b. empty =>  Eq [a]+We solve the simple (Eq [a]), under nestTcS, and then turn our attention to+the implications.  It's definitely fine to use the solved dictionaries on+the inner implications, and it can make a significant performance difference+if you do so.+-}++-- Getters and setters of GHC.Tc.Utils.Env fields+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- Getter of inerts and worklist+getTcSInertsRef :: TcS (IORef InertSet)+getTcSInertsRef = TcS (return . tcs_inerts)++getTcSWorkListRef :: TcS (IORef WorkList)+getTcSWorkListRef = TcS (return . tcs_worklist)++getTcSInerts :: TcS InertSet+getTcSInerts = getTcSInertsRef >>= readTcRef++setTcSInerts :: InertSet -> TcS ()+setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }++getWorkListImplics :: TcS (Bag Implication)+getWorkListImplics+  = do { wl_var <- getTcSWorkListRef+       ; wl_curr <- readTcRef wl_var+       ; return (wl_implics wl_curr) }++pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)+-- Push the level and run thing_inside+-- However, thing_inside should not generate any work items+#if defined(DEBUG)+pushLevelNoWorkList err_doc (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM $+                 thing_inside (env { tcs_worklist = wl_panic })+        )+  where+    wl_panic  = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc+                         -- This panic checks that the thing-inside+                         -- does not emit any work-list constraints+#else+pushLevelNoWorkList _ (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check+#endif++updWorkListTcS :: (WorkList -> WorkList) -> TcS ()+updWorkListTcS f+  = do { wl_var <- getTcSWorkListRef+       ; updTcRef wl_var f }++emitWorkNC :: [CtEvidence] -> TcS ()+emitWorkNC evs+  | null evs+  = return ()+  | otherwise+  = emitWork (map mkNonCanonical evs)++emitWork :: [Ct] -> TcS ()+emitWork [] = return ()   -- avoid printing, among other work+emitWork cts+  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))+       ; updWorkListTcS (extendWorkListCts cts) }++emitImplication :: Implication -> TcS ()+emitImplication implic+  = updWorkListTcS (extendWorkListImplic implic)++newTcRef :: a -> TcS (TcRef a)+newTcRef x = wrapTcS (TcM.newTcRef x)++readTcRef :: TcRef a -> TcS a+readTcRef ref = wrapTcS (TcM.readTcRef ref)++writeTcRef :: TcRef a -> a -> TcS ()+writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)++updTcRef :: TcRef a -> (a->a) -> TcS ()+updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)++getTcEvBindsVar :: TcS EvBindsVar+getTcEvBindsVar = TcS (return . tcs_ev_binds)++getTcLevel :: TcS TcLevel+getTcLevel = wrapTcS TcM.getTcLevel++getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet+getTcEvTyCoVars ev_binds_var+  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var++getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap+getTcEvBindsMap ev_binds_var+  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var++setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()+setTcEvBindsMap ev_binds_var binds+  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds++unifyTyVar :: TcTyVar -> TcType -> TcS ()+-- Unify a meta-tyvar with a type+-- We keep track of how many unifications have happened in tcs_unified,+--+-- We should never unify the same variable twice!+unifyTyVar tv ty+  = assertPpr (isMetaTyVar tv) (ppr tv) $+    TcS $ \ env ->+    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)+       ; TcM.writeMetaTyVar tv ty+       ; TcM.updTcRef (tcs_unified env) (+1) }++reportUnifications :: TcS a -> TcS (Int, a)+reportUnifications (TcS thing_inside)+  = TcS $ \ env ->+    do { inner_unified <- TcM.newTcRef 0+       ; res <- thing_inside (env { tcs_unified = inner_unified })+       ; n_unifs <- TcM.readTcRef inner_unified+       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)+       ; return (n_unifs, res) }++getDefaultInfo ::  TcS ([Type], (Bool, Bool))+getDefaultInfo = wrapTcS TcM.tcGetDefaultTys++getWorkList :: TcS WorkList+getWorkList = do { wl_var <- getTcSWorkListRef+                 ; wrapTcS (TcM.readTcRef wl_var) }++selectNextWorkItem :: TcS (Maybe Ct)+-- Pick which work item to do next+-- See Note [Prioritise equalities]+selectNextWorkItem+  = do { wl_var <- getTcSWorkListRef+       ; wl <- readTcRef wl_var+       ; case selectWorkItem wl of {+           Nothing -> return Nothing ;+           Just (ct, new_wl) ->+    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)+         -- This is done by GHC.Tc.Solver.Interact.chooseInstance+       ; writeTcRef wl_var new_wl+       ; return (Just ct) } } }++-- Just get some environments needed for instance looking up and matching+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++getInstEnvs :: TcS InstEnvs+getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs++getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)+getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs++getTopEnv :: TcS HscEnv+getTopEnv = wrapTcS $ TcM.getTopEnv++getGblEnv :: TcS TcGblEnv+getGblEnv = wrapTcS $ TcM.getGblEnv++getLclEnv :: TcS TcLclEnv+getLclEnv = wrapTcS $ TcM.getLclEnv++tcLookupClass :: Name -> TcS Class+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c++tcLookupId :: Name -> TcS Id+tcLookupId n = wrapTcS $ TcM.tcLookupId n++-- Setting names as used (used in the deriving of Coercible evidence)+-- Too hackish to expose it to TcS? In that case somehow extract the used+-- constructors from the result of solveInteract+addUsedGREs :: [GlobalRdrElt] -> TcS ()+addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres++addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()+addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre++keepAlive :: Name -> TcS ()+keepAlive = wrapTcS . TcM.keepAlive++-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()+-- Check that we do not try to use an instance before it is available.  E.g.+--    instance Eq T where ...+--    f x = $( ... (\(p::T) -> p == p)... )+-- Here we can't use the equality function from the instance in the splice++checkWellStagedDFun loc what pred+  | TopLevInstance { iw_dfun_id = dfun_id } <- what+  , let bind_lvl = TcM.topIdLvl dfun_id+  , bind_lvl > impLevel+  = wrapTcS $ TcM.setCtLocM loc $+    do { use_stage <- TcM.getStage+       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }++  | otherwise+  = return ()    -- Fast path for common case+  where+    pp_thing = text "instance for" <+> quotes (ppr pred)++pprEq :: TcType -> TcType -> SDoc+pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2++isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)+isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)++isFilledMetaTyVar :: TcTyVar -> TcS Bool+isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)++zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet+zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)++zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]+zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)++zonkCo :: Coercion -> TcS Coercion+zonkCo = wrapTcS . TcM.zonkCo++zonkTcType :: TcType -> TcS TcType+zonkTcType ty = wrapTcS (TcM.zonkTcType ty)++zonkTcTypes :: [TcType] -> TcS [TcType]+zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)++zonkTcTyVar :: TcTyVar -> TcS TcType+zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)++zonkSimples :: Cts -> TcS Cts+zonkSimples cts = wrapTcS (TcM.zonkSimples cts)++zonkWC :: WantedConstraints -> TcS WantedConstraints+zonkWC wc = wrapTcS (TcM.zonkWC wc)++zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar+zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)++----------------------------+pprKicked :: Int -> SDoc+pprKicked 0 = empty+pprKicked n = parens (int n <+> text "kicked out")++{- *********************************************************************+*                                                                      *+*              The Unification Level Flag                              *+*                                                                      *+********************************************************************* -}++{- Note [The Unification Level Flag]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a deep tree of implication constraints+   forall[1] a.                              -- Outer-implic+      C alpha[1]                               -- Simple+      forall[2] c. ....(C alpha[1])....        -- Implic-1+      forall[2] b. ....(alpha[1] ~ Int)....    -- Implic-2++The (C alpha) is insoluble until we know alpha.  We solve alpha+by unifying alpha:=Int somewhere deep inside Implic-2. But then we+must try to solve the Outer-implic all over again. This time we can+solve (C alpha) both in Outer-implic, and nested inside Implic-1.++When should we iterate solving a level-n implication?+Answer: if any unification of a tyvar at level n takes place+        in the ic_implics of that implication.++* What if a unification takes place at level n-1? Then don't iterate+  level n, because we'll iterate level n-1, and that will in turn iterate+  level n.++* What if a unification takes place at level n, in the ic_simples of+  level n?  No need to track this, because the kick-out mechanism deals+  with it.  (We can't drop kick-out in favour of iteration, because kick-out+  works for skolem-equalities, not just unifications.)++So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps+track of+  - Whether any unifications at all have taken place (Nothing => no unifications)+  - If so, what is the outermost level that has seen a unification (Just lvl)++The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver.++It helpful not to iterate unless there is a chance of progress.  #8474 is+an example:++  * There's a deeply-nested chain of implication constraints.+       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int++  * From the innermost one we get a [D] alpha[1] ~ Int,+    so we can unify.++  * It's better not to iterate the inner implications, but go all the+    way out to level 1 before iterating -- because iterating level 1+    will iterate the inner levels anyway.++(In the olden days when we "floated" thse Derived constraints, this was+much, much more important -- we got exponential behaviour, as each iteration+produced the same Derived constraint.)+-}+++resetUnificationFlag :: TcS Bool+-- We are at ambient level i+-- If the unification flag = Just i, reset it to Nothing and return True+-- Otherwise leave it unchanged and return False+resetUnificationFlag+  = TcS $ \env ->+    do { let ref = tcs_unif_lvl env+       ; ambient_lvl <- TcM.getTcLevel+       ; mb_lvl <- TcM.readTcRef ref+       ; TcM.traceTc "resetUnificationFlag" $+         vcat [ text "ambient:" <+> ppr ambient_lvl+              , text "unif_lvl:" <+> ppr mb_lvl ]+       ; case mb_lvl of+           Nothing       -> return False+           Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl+                         -> return False+                         | otherwise+                         -> do { TcM.writeTcRef ref Nothing+                               ; return True } }++setUnificationFlag :: TcLevel -> TcS ()+-- (setUnificationFlag i) sets the unification level to (Just i)+-- unless it already is (Just j) where j <= i+setUnificationFlag lvl+  = TcS $ \env ->+    do { let ref = tcs_unif_lvl env+       ; mb_lvl <- TcM.readTcRef ref+       ; case mb_lvl of+           Just unif_lvl | lvl `deeperThanOrSame` unif_lvl+                         -> return ()+           _ -> TcM.writeTcRef ref (Just lvl) }+++{- *********************************************************************+*                                                                      *+*                Instantiation etc.+*                                                                      *+********************************************************************* -}++-- Instantiations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)+instDFunType dfun_id inst_tys+  = wrapTcS $ TcM.instDFunType dfun_id inst_tys++newFlexiTcSTy :: Kind -> TcS TcType+newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)++cloneMetaTyVar :: TcTyVar -> TcS TcTyVar+cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)++instFlexi :: [TKVar] -> TcS TCvSubst+instFlexi = instFlexiX emptyTCvSubst++instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst+instFlexiX subst tvs+  = wrapTcS (foldlM instFlexiHelper subst tvs)++instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst+instFlexiHelper subst tv+  = do { uniq <- TcM.newUnique+       ; details <- TcM.newMetaDetails TauTv+       ; let name = setNameUnique (tyVarName tv) uniq+             kind = substTyUnchecked subst (tyVarKind tv)+             ty'  = mkTyVarTy (mkTcTyVar name kind details)+       ; TcM.traceTc "instFlexi" (ppr ty')+       ; return (extendTvSubst subst tv ty') }++matchGlobalInst :: DynFlags+                -> Bool      -- True <=> caller is the short-cut solver+                             -- See Note [Shortcut solving: overlap]+                -> Class -> [Type] -> TcS TcM.ClsInstResult+matchGlobalInst dflags short_cut cls tys+  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)++tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])+tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs++-- Creating and setting evidence variables and CtFlavors+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data MaybeNew = Fresh CtEvidence | Cached EvExpr++isFresh :: MaybeNew -> Bool+isFresh (Fresh {})  = True+isFresh (Cached {}) = False++freshGoals :: [MaybeNew] -> [CtEvidence]+freshGoals mns = [ ctev | Fresh ctev <- mns ]++getEvExpr :: MaybeNew -> EvExpr+getEvExpr (Fresh ctev) = ctEvExpr ctev+getEvExpr (Cached evt) = evt++setEvBind :: EvBind -> TcS ()+setEvBind ev_bind+  = do { evb <- getTcEvBindsVar+       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }++-- | Mark variables as used filling a coercion hole+useVars :: CoVarSet -> TcS ()+useVars co_vars+  = do { ev_binds_var <- getTcEvBindsVar+       ; let ref = ebv_tcvs ev_binds_var+       ; wrapTcS $+         do { tcvs <- TcM.readTcRef ref+            ; let tcvs' = tcvs `unionVarSet` co_vars+            ; TcM.writeTcRef ref tcvs' } }++-- | Equalities only+setWantedEq :: TcEvDest -> Coercion -> TcS ()+setWantedEq (HoleDest hole) co+  = do { useVars (coVarsOfCo co)+       ; fillCoercionHole hole co }+setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)++-- | Good for both equalities and non-equalities+setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()+setWantedEvTerm (HoleDest hole) tm+  | Just co <- evTermCoercion_maybe tm+  = do { useVars (coVarsOfCo co)+       ; fillCoercionHole hole co }+  | otherwise+  = -- See Note [Yukky eq_sel for a HoleDest]+    do { let co_var = coHoleCoVar hole+       ; setEvBind (mkWantedEvBind co_var tm)+       ; fillCoercionHole hole (mkTcCoVarCo co_var) }++setWantedEvTerm (EvVarDest ev_id) tm+  = setEvBind (mkWantedEvBind ev_id tm)++{- Note [Yukky eq_sel for a HoleDest]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How can it be that a Wanted with HoleDest gets evidence that isn't+just a coercion? i.e. evTermCoercion_maybe returns Nothing.++Consider [G] forall a. blah => a ~ T+         [W] S ~# T++Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~+T) in the quantified constraints, and wraps the (boxed) evidence it+gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put+that term into a coercion, so we add a value binding+    h = eq_sel (...)+and the coercion variable h to fill the coercion hole.+We even re-use the CoHole's Id for this binding!++Yuk!+-}++fillCoercionHole :: CoercionHole -> Coercion -> TcS ()+fillCoercionHole hole co+  = do { wrapTcS $ TcM.fillCoercionHole hole co+       ; kickOutAfterFillingCoercionHole hole co }++setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()+setEvBindIfWanted ev tm+  = case ev of+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm+      _                             -> return ()++newTcEvBinds :: TcS EvBindsVar+newTcEvBinds = wrapTcS TcM.newTcEvBinds++newNoTcEvBinds :: TcS EvBindsVar+newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds++newEvVar :: TcPredType -> TcS EvVar+newEvVar pred = wrapTcS (TcM.newEvVar pred)++newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence+-- Make a new variable of the given PredType,+-- immediately bind it to the given term+-- and return its CtEvidence+-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint+newGivenEvVar loc (pred, rhs)+  = do { new_ev <- newBoundEvVarId pred rhs+       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }++-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the+-- given term+newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar+newBoundEvVarId pred rhs+  = do { new_ev <- newEvVar pred+       ; setEvBind (mkGivenEvBind new_ev rhs)+       ; return new_ev }++newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]+newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts++emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion+-- | Emit a new Wanted equality into the work-list+emitNewWantedEq loc role ty1 ty2+  = do { (ev, co) <- newWantedEq loc role ty1 ty2+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))+       ; return co }++-- | Make a new equality CtEvidence+newWantedEq :: CtLoc -> Role -> TcType -> TcType+            -> TcS (CtEvidence, Coercion)+newWantedEq = newWantedEq_SI WDeriv++newWantedEq_SI :: ShadowInfo -> CtLoc -> Role+               -> TcType -> TcType+               -> TcS (CtEvidence, Coercion)+newWantedEq_SI si loc role ty1 ty2+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty+       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)+       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole+                           , ctev_nosh = si+                           , ctev_loc = loc}+                , mkHoleCo hole ) }+  where+    pty = mkPrimEqPredRole role ty1 ty2++-- no equalities here. Use newWantedEq instead+newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence+newWantedEvVarNC = newWantedEvVarNC_SI WDeriv++newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence+-- Don't look up in the solved/inerts; we know it's not there+newWantedEvVarNC_SI si loc pty+  = do { new_ev <- newEvVar pty+       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$+                                         pprCtLoc loc)+       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev+                          , ctev_nosh = si+                          , ctev_loc = loc })}++newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew+newWantedEvVar = newWantedEvVar_SI WDeriv++newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew+-- For anything except ClassPred, this is the same as newWantedEvVarNC+newWantedEvVar_SI si loc pty+  = do { mb_ct <- lookupInInerts loc pty+       ; case mb_ct of+            Just ctev+              | not (isDerived ctev)+              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev+                    ; return $ Cached (ctEvExpr ctev) }+            _ -> do { ctev <- newWantedEvVarNC_SI si loc pty+                    ; return (Fresh ctev) } }++newWanted :: CtLoc -> PredType -> TcS MaybeNew+-- Deals with both equalities and non equalities. Tries to look+-- up non-equalities in the cache+newWanted = newWanted_SI WDeriv++newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew+newWanted_SI si loc pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2+  | otherwise+  = newWantedEvVar_SI si loc pty++-- deals with both equalities and non equalities. Doesn't do any cache lookups.+newWantedNC :: CtLoc -> PredType -> TcS CtEvidence+newWantedNC loc pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = fst <$> newWantedEq loc role ty1 ty2+  | otherwise+  = newWantedEvVarNC loc pty++emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()+emitNewDeriveds loc preds+  | null preds+  = return ()+  | otherwise+  = do { evs <- mapM (newDerivedNC loc) preds+       ; traceTcS "Emitting new deriveds" (ppr evs)+       ; updWorkListTcS (extendWorkListDeriveds evs) }++emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()+-- Create new equality Derived and put it in the work list+-- There's no caching, no lookupInInerts+emitNewDerivedEq loc role ty1 ty2+  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)+       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }+         -- Very important: put in the wl_eqs+         -- See Note [Prioritise equalities] in GHC.Tc.Solver.InertSet+         -- (Avoiding fundep iteration)++newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence+newDerivedNC loc pred+  = return $ CtDerived { ctev_pred = pred, ctev_loc = loc }++-- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? ---------+-- | Checks if the depth of the given location is too much. Fails if+-- it's too big, with an appropriate error message.+checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced+                    -> TcS ()+checkReductionDepth loc ty+  = do { dflags <- getDynFlags+       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $+         wrapErrTcS $+         solverDepthErrorTcS loc ty }++matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType))+-- Given (F tys) return (ty, co), where co :: ty ~N F tys+matchFam tycon args = fmap (fmap (first mkTcSymCo)) $ wrapTcS $ matchFamTcM tycon args++matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType))+-- Given (F tys) return (ty, co), where co :: F tys ~N ty+matchFamTcM tycon args+  = do { fam_envs <- FamInst.tcGetFamInstEnvs+       ; let match_fam_result+              = reduceTyFamApp_maybe fam_envs Nominal tycon args+       ; TcM.traceTc "matchFamTcM" $+         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)+              , ppr_res match_fam_result ]+       ; return match_fam_result }+  where+    ppr_res Nothing        = text "Match failed"+    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")+                                2 (vcat [ text "Rewrites to:" <+> ppr ty+                                        , text "Coercion:" <+> ppr co ])  {- ************************************************************************
compiler/GHC/Tc/Solver/Rewrite.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns  #-}-{-# LANGUAGE CPP           #-}+ {-# LANGUAGE DeriveFunctor #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -9,8 +9,6 @@    rewriteType  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core.TyCo.Ppr ( pprTyVar )@@ -28,7 +26,9 @@ import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Tc.Solver.Monad as TcS+import GHC.Tc.Solver.Types  import GHC.Utils.Misc import GHC.Data.Maybe@@ -257,7 +257,7 @@   = do { traceTcS "rewrite_args {" (vcat (map ppr tys))        ; (tys', cos, kind_co)            <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys)-       ; MASSERT( isReflMCo kind_co )+       ; massert (isReflMCo kind_co)        ; traceTcS "rewrite }" (vcat (map ppr tys'))        ; return (tys', cos) } @@ -334,7 +334,7 @@ unexpanded synonym. See also Note [Rewriting synonyms].  Where do we actually perform rewriting within a type? See Note [Rewritable] in-GHC.Tc.Solver.Monad.+GHC.Tc.Solver.InertSet.  Note [rewrite_args performance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -769,8 +769,8 @@   --   rewrite_exact_fam_app      lifts out the application to top level   -- Postcondition: Coercion :: Xi ~ F tys rewrite_fam_app tc tys  -- Can be over-saturated-    = ASSERT2( tys `lengthAtLeast` tyConArity tc-             , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)+    = assertPpr (tys `lengthAtLeast` tyConArity tc)+                (ppr tc $$ ppr (tyConArity tc) $$ ppr tys) $                   -- Type functions are saturated                  -- The type function might be *over* saturated@@ -968,7 +968,7 @@                          ppr rhs_ty $$ ppr ctev)                     ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)                           rewrite_co  = case (ct_eq_rel, eq_rel) of-                            (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )+                            (ReprEq, _rel)  -> assert (_rel == ReprEq )                                     -- if this ASSERT fails, then                                     -- eqCanRewriteFR answered incorrectly                                                rewrite_co1
+ compiler/GHC/Tc/Solver/Types.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | Utility types used within the constraint solver+module GHC.Tc.Solver.Types (+    -- Inert CDictCans+    DictMap, emptyDictMap, findDictsByClass, addDict, addDictCt,+    addDictsByClass, delDict, foldDicts, filterDicts, findDict,+    dictsToBag, partitionDicts,++    FunEqMap, emptyFunEqs, foldFunEqs, findFunEq, insertFunEq,+    findFunEqsByTyCon,++    TcAppMap, isEmptyTcAppMap, insertTcApp, alterTcApp, filterTcAppMap,++    EqualCtList, pattern EqualCtList,+    equalCtListToList, filterEqualCtList, unitEqualCtList,+    listToEqualCtList, addToEqualCtList,+  ) where++import GHC.Prelude++import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType++import GHC.Core.Class+import GHC.Core.Map.Type+import GHC.Core.Predicate+import GHC.Core.TyCon+import GHC.Core.TyCon.Env++import GHC.Data.Bag+import GHC.Data.Maybe+import GHC.Data.TrieMap+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.Foldable+import Data.List.NonEmpty ( NonEmpty(..), nonEmpty, cons )+import qualified Data.List.NonEmpty as NE++{- *********************************************************************+*                                                                      *+                   TcAppMap+*                                                                      *+************************************************************************++Note [Use loose types in inert set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Whenever we are looking up an inert dictionary (CDictCan) or function+equality (CEqCan), we use a TcAppMap, which uses the Unique of the+class/type family tycon and then a trie which maps the arguments. This+trie does *not* need to match the kinds of the arguments; this Note+explains why.++Consider the types ty0 = (T ty1 ty2 ty3 ty4) and ty0' = (T ty1' ty2' ty3' ty4'),+where ty4 and ty4' have different kinds. Let's further assume that both types+ty0 and ty0' are well-typed. Because the kind of T is closed, it must be that+one of the ty1..ty3 does not match ty1'..ty3' (and that the kind of the fourth+argument to T is dependent on whichever one changed). Since we are matching+all arguments, during the inert-set lookup, we know that ty1..ty3 do indeed+match ty1'..ty3'. Therefore, the kind of ty4 and ty4' must match, too --+without ever looking at it.++Accordingly, we use LooseTypeMap, which skips the kind check when looking+up a type. I (Richard E) believe this is just an optimization, and that+looking at kinds would be harmless.++-}++type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a)+    -- Indexed by tycon then the arg types, using "loose" matching, where+    -- we don't require kind equality. This allows, for example, (a |> co)+    -- to match (a).+    -- See Note [Use loose types in inert set]+    -- Used for types and classes; hence UniqDFM+    -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here++isEmptyTcAppMap :: TcAppMap a -> Bool+isEmptyTcAppMap m = isEmptyDTyConEnv m++emptyTcAppMap :: TcAppMap a+emptyTcAppMap = emptyDTyConEnv++findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a+findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc+                        ; lookupTM tys tys_map }++delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a+delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc++insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a+insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc+  where+    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))++alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a+alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc+  where+    alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)+    alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))++filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a+filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m+  where+    one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)+    one_tycon tm+      | isEmptyTM filtered_tm = Nothing+      | otherwise             = Just filtered_tm+      where+        filtered_tm = filterTM f tm++tcAppMapToBag :: TcAppMap a -> Bag a+tcAppMapToBag m = foldTcAppMap consBag m emptyBag++foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b+foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m++{- *********************************************************************+*                                                                      *+                   DictMap+*                                                                      *+********************************************************************* -}++type DictMap a = TcAppMap a++emptyDictMap :: DictMap a+emptyDictMap = emptyTcAppMap++findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a+findDict m loc cls tys+  | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]+  = Nothing++  | Just {} <- isCallStackPred cls tys+  , OccurrenceOf {} <- ctLocOrigin loc+  = Nothing             -- See Note [Solving CallStack constraints]++  | otherwise+  = findTcApp m (classTyCon cls) tys++findDictsByClass :: DictMap a -> Class -> Bag a+findDictsByClass m cls+  | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag+  | otherwise                                     = emptyBag++delDict :: DictMap a -> Class -> [Type] -> DictMap a+delDict m cls tys = delTcApp m (classTyCon cls) tys++addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a+addDict m cls tys item = insertTcApp m (classTyCon cls) tys item++addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct+-- Like addDict, but combines [W] and [D] to [WD]+-- See Note [KeepBoth] in GHC.Tc.Solver.Interact+addDictCt m cls tys new_ct = alterTcApp m (classTyCon cls) tys xt_ct+  where+    new_ct_ev = ctEvidence new_ct++    xt_ct :: Maybe Ct -> Maybe Ct+    xt_ct (Just old_ct)+      | CtWanted { ctev_nosh = WOnly } <- old_ct_ev+      , CtDerived {} <- new_ct_ev+      = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }})+      | CtDerived {} <- old_ct_ev+      , CtWanted { ctev_nosh = WOnly } <- new_ct_ev+      = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }})+      where+        old_ct_ev = ctEvidence old_ct++    xt_ct _ = Just new_ct++addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct+addDictsByClass m cls items+  = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)+  where+    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm+    add ct _ = pprPanic "addDictsByClass" (ppr ct)++filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct+filterDicts f m = filterTcAppMap f m++partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)+partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap)+  where+    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)+                       | otherwise = (yeses,              add ct noes)+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m+      = addDict m cls tys ct+    add ct _ = pprPanic "partitionDicts" (ppr ct)++dictsToBag :: DictMap a -> Bag a+dictsToBag = tcAppMapToBag++foldDicts :: (a -> b -> b) -> DictMap a -> b -> b+foldDicts = foldTcAppMap++{- Note [Tuples hiding implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f,g :: (?x::Int, C a) => a -> a+   f v = let ?x = 4 in g v++The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).+We must /not/ solve this from the Given (?x::Int, C a), because of+the intervening binding for (?x::Int).  #14218.++We deal with this by arranging that we always fail when looking up a+tuple constraint that hides an implicit parameter. Not that this applies+  * both to the inert_dicts (lookupInertDict)+  * and to the solved_dicts (looukpSolvedDict)+An alternative would be not to extend these sets with such tuple+constraints, but it seemed more direct to deal with the lookup.++Note [Solving CallStack constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose f :: HasCallStack => blah.  Then++* Each call to 'f' gives rise to+    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f+  with a CtOrigin that says "OccurrenceOf f".+  Remember that HasCallStack is just shorthand for+    IP "callStack CallStack+  See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence++* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by+  pushing the call-site info on the stack, and changing the CtOrigin+  to record that has been done.+   Bind:  s1 = pushCallStack <site-info> s2+   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin++* Then, and only then, we can solve the constraint from an enclosing+  Given.++So we must be careful /not/ to solve 's1' from the Givens.  Again,+we ensure this by arranging that findDict always misses when looking+up souch constraints.+-}++{- *********************************************************************+*                                                                      *+                   FunEqMap+*                                                                      *+********************************************************************* -}++type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair++emptyFunEqs :: TcAppMap a+emptyFunEqs = emptyTcAppMap++findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a+findFunEq m tc tys = findTcApp m tc tys++findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]+-- Get inert function equation constraints that have the given tycon+-- in their head.  Not that the constraints remain in the inert set.+-- We use this to check for derived interactions with built-in type-function+-- constructors.+findFunEqsByTyCon m tc+  | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []+  | otherwise                       = []++foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b+foldFunEqs = foldTcAppMap++insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a+insertFunEq m tc tys val = insertTcApp m tc tys val++{- *********************************************************************+*                                                                      *+                   EqualCtList+*                                                                      *+********************************************************************* -}++{- Note [EqualCtList invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    * All are equalities+    * All these equalities have the same LHS+    * The list is never empty+    * No element of the list can rewrite any other+    * Derived before Wanted++From the fourth invariant it follows that the list is+   - A single [G], or+   - Zero or one [D] or [WD], followed by any number of [W]++The Wanteds can't rewrite anything which is why we put them last+-}++newtype EqualCtList = MkEqualCtList (NonEmpty Ct)+  deriving newtype Outputable+  -- See Note [EqualCtList invariants]++-- | Pattern synonym for easy unwrapping. NB: unidirectional to+-- preserve invariants.+pattern EqualCtList :: NonEmpty Ct -> EqualCtList+pattern EqualCtList cts <- MkEqualCtList cts+{-# COMPLETE EqualCtList #-}++unitEqualCtList :: Ct -> EqualCtList+unitEqualCtList ct = MkEqualCtList (ct :| [])++addToEqualCtList :: Ct -> EqualCtList -> EqualCtList+-- NB: This function maintains the "derived-before-wanted" invariant of EqualCtList,+-- but not the others. See Note [EqualCtList invariants]+addToEqualCtList ct (MkEqualCtList old_eqs)+  | isWantedCt ct+  , eq1 :| eqs <- old_eqs+  = MkEqualCtList (eq1 :| ct : eqs)+  | otherwise+  = MkEqualCtList (ct `cons` old_eqs)++filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList+filterEqualCtList pred (MkEqualCtList cts)+  = fmap MkEqualCtList (nonEmpty $ NE.filter pred cts)++equalCtListToList :: EqualCtList -> [Ct]+equalCtListToList (MkEqualCtList cts) = toList cts++listToEqualCtList :: [Ct] -> Maybe EqualCtList+-- NB: This does not maintain invariants other than having the EqualCtList be+-- non-empty+listToEqualCtList cts = MkEqualCtList <$> nonEmpty cts
compiler/GHC/Tc/TyCl.hs view
@@ -4,7 +4,8 @@  -} -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections, ScopedTypeVariables, MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-}@@ -25,8 +26,6 @@         wrongKindOfFamily     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -91,6 +90,8 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc  import Control.Monad@@ -1534,7 +1535,7 @@   case info of     DataFamily         -> DataFamilyFlavour mb_parent_tycon     OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon-    ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]+    ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) -- See Note [Closed type family mb_parent_tycon]                           ClosedTypeFamilyFlavour  {- Note [Closed type family mb_parent_tycon]@@ -2377,7 +2378,7 @@ tcTyClDecl1 _parent roles_info             (SynDecl { tcdLName = L _ tc_name                      , tcdRhs   = rhs })-  = ASSERT( isNothing _parent )+  = assert (isNothing _parent )     fmap noDerivInfos $     tcTySynRhs roles_info tc_name rhs @@ -2385,7 +2386,7 @@ tcTyClDecl1 _parent roles_info             decl@(DataDecl { tcdLName = L _ tc_name                            , tcdDataDefn = defn })-  = ASSERT( isNothing _parent )+  = assert (isNothing _parent) $     tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn  tcTyClDecl1 _parent roles_info@@ -2396,7 +2397,7 @@                        , tcdSigs = sigs                        , tcdATs = ats                        , tcdATDefs = at_defs })-  = ASSERT( isNothing _parent )+  = assert (isNothing _parent) $     do { clas <- tcClassDecl1 roles_info class_name hs_ctxt                               meths fundeps sigs ats at_defs        ; return (noDerivInfos (classTyCon clas)) }@@ -2550,7 +2551,7 @@              vis_pats  = numVisibleArgs hs_pats         -- Kind of family check-       ; ASSERT( fam_tc_name == tc_name )+       ; assert (fam_tc_name == tc_name) $          checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)         -- Arity check@@ -2957,7 +2958,7 @@     mk_tc_rhs _ tycon data_cons       = case new_or_data of           DataType -> return (mkDataTyConRhs data_cons)-          NewType  -> ASSERT( not (null data_cons) )+          NewType  -> assert (not (null data_cons)) $                       mkNewTyConRhs tc_name tycon (head data_cons)  @@ -4244,6 +4245,11 @@     data_cons = tyConDataCons tc      groups = equivClasses cmp_fld (concatMap get_fields data_cons)+    -- This spot seems OK with non-determinism. cmp_fld is used only in equivClasses+    -- which produces equivalence classes.+    -- The order of these equivalence classes might conceivably (non-deterministically)+    -- depend on the result of this comparison, but that just affects the order in which+    -- fields are checked for compatibility. It will not affect the compiled binary.     cmp_fld (f1,_) (f2,_) = flLabel f1 `uniqCompareFS` flLabel f2     get_fields con = dataConFieldLabels con `zip` repeat con         -- dataConFieldLabels may return the empty list, which is fine@@ -4298,7 +4304,7 @@     has_field con = fld `elem` (dataConFieldLabels con)     is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field -    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field+    con1 = assert (not (null cons_with_field)) $ head cons_with_field     (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1     eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)     inst_tys = substTyVars eq_subst univ_tvs@@ -4427,12 +4433,12 @@                    user_tvbs_invariant                      =    Set.fromList (filterEqSpec eq_spec univs ++ exs)                        == Set.fromList user_tvs-             ; MASSERT2( user_tvbs_invariant-                       , vcat ([ ppr con+             ; massertPpr user_tvbs_invariant+                          $ vcat ([ ppr con                                , ppr univs                                , ppr exs                                , ppr eq_spec-                               , ppr user_tvs ])) }+                               , ppr user_tvs ]) }          ; traceTc "Done validity of data con" $           vcat [ ppr con@@ -5039,8 +5045,8 @@ -- See Note [Inferring visible dependent quantification] -- Only types without a signature (CUSK or SAK) here addVDQNote tycon thing_inside-  | ASSERT2( isTcTyCon tycon, ppr tycon )-    ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind )+  | assertPpr (isTcTyCon tycon) (ppr tycon) $+    assertPpr (not (tcTyConIsPoly tycon)) (ppr tycon $$ ppr tc_kind)     has_vdq   = addLandmarkErrCtxt vdq_warning thing_inside   | otherwise
compiler/GHC/Tc/TyCl/Build.hs view
@@ -3,8 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Tc.TyCl.Build (@@ -15,8 +15,6 @@         newImplicitBinder, newTyConRepName     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Iface.Env@@ -79,6 +77,8 @@         -- has a single argument (Foo a) that is a *type class*, so         -- dataConInstOrigArgTys returns []. +    -- Eta-reduce the newtype+    -- See Note [Newtype eta] in GHC.Core.TyCon     etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can     etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty     etad_rhs   :: Type     -- See Note [Tricky iface loop] in GHC.Iface.Load@@ -89,13 +89,52 @@                -> Type          -- Rhs type                -> ([TyVar], [Role], Type)  -- Eta-reduced version                                            -- (tyvars in normal order)-    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,-                                  Just tv <- getTyVar_maybe arg,-                                  tv == a,-                                  not (a `elemVarSet` tyCoVarsOfType fun)-                                = eta_reduce as rs fun-    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)+    eta_reduce (a:as) (_:rs) ty+      | Just (fun, arg) <- splitAppTy_maybe ty+      , Just tv <- getTyVar_maybe arg+      , tv == a+      , not (a `elemVarSet` tyCoVarsOfType fun)+      , typeKind fun `eqType` typeKind (mkTyConApp tycon (mkTyVarTys $ reverse as))+        -- Why this kind-check?  See Note [Newtype eta and homogeneous axioms]+      = eta_reduce as rs fun+    eta_reduce as rs ty = (reverse as, reverse rs, ty) +{- Note [Newtype eta and homogeneous axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When eta-reducing a newtype, we must be careful to make sure the axiom+is homogeneous.  (That is, the two types related by the axiom must+have the same kind.)  All known proofs of type safety for Core rely on+the homogeneity of axioms, so let's not monkey with that.++It is easy to mistakenly make an inhomogeneous axiom (#19739):+  type T :: forall (a :: Type) -> Type+  newtype T a = MkT (Proxy a)++Can we eta-reduce, thus?+  axT :: T ~ Proxy++No!  Because+   T     :: forall a -> Type+   Proxy :: Type     -> Type++This is inhomogeneous. Hence, we have an extra kind-check in eta_reduce,+to make sure the reducts have the same kind. This is simple, although+perhaps quadratic in complexity, if we eta-reduce many arguments (which+seems vanishingly unlikely in practice).  But NB that the free-variable+check, which immediately precedes the kind check, is also potentially+quadratic.++There are other ways we could do the check (discussion on #19739):++* We could look at the sequence of binders on the newtype and on the+  head of the representation type, and make sure the visibilities on+  the binders match up. This is quite a bit more code, and the reasoning+  is subtler.++* We could, say, do the kind-check at the end and then backtrack until the+  kinds match up. Hard to know whether that's more performant or not.+-}+ ------------------------------------------------------ buildDataCon :: FamInstEnvs             -> Name@@ -183,19 +222,19 @@             pat_ty field_labels   = -- The assertion checks that the matcher is     -- compatible with the pattern synonym-    ASSERT2((and [ univ_tvs `equalLength` univ_tvs1-                 , ex_tvs `equalLength` ex_tvs1-                 , pat_ty `eqType` substTy subst (scaledThing pat_ty1)-                 , prov_theta `eqTypes` substTys subst prov_theta1-                 , req_theta `eqTypes` substTys subst req_theta1-                 , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))-                 ])-            , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1+    assertPpr (and [ univ_tvs `equalLength` univ_tvs1+                   , ex_tvs `equalLength` ex_tvs1+                   , pat_ty `eqType` substTy subst (scaledThing pat_ty1)+                   , prov_theta `eqTypes` substTys subst prov_theta1+                   , req_theta `eqTypes` substTys subst req_theta1+                   , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))+                   ])+              (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1                     , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1                     , ppr pat_ty <+> twiddle <+> ppr pat_ty1                     , ppr prov_theta <+> twiddle <+> ppr prov_theta1                     , ppr req_theta <+> twiddle <+> ppr req_theta1-                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))+                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]) $     mkPatSyn src_name declared_infix              (univ_tvs, req_theta) (ex_tvs, prov_theta)              arg_tys pat_ty
compiler/GHC/Tc/TyCl/Class.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -27,8 +27,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs@@ -61,6 +59,7 @@ import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Core.TyCon import GHC.Data.Maybe@@ -369,7 +368,7 @@ -- Return the "local method type": --      forall c. Ix x => (ty2,c) -> ty1 instantiateMethod clas sel_id inst_tys-  = ASSERT( ok_first_pred ) local_meth_ty+  = assert ok_first_pred local_meth_ty   where     rho_ty = piResultTys (idType sel_id) inst_tys     (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -19,8 +19,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs@@ -80,6 +78,7 @@ import GHC.Types.Name.Set import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )@@ -748,7 +747,7 @@               ; axiom_name  <- newFamInstAxiomName lfam_name [pats]               ; tc_rhs <- case new_or_data of                      DataType -> return (mkDataTyConRhs data_cons)-                     NewType  -> ASSERT( not (null data_cons) )+                     NewType  -> assert (not (null data_cons)) $                                  mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)                ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)@@ -1054,6 +1053,23 @@   themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities   does. +* Happily, we don't need to worry about the possibility of+  building an inhomogeneous axiom, described in GHC.Tc.TyCl.Build+  Note [Newtype eta and homogeneous axioms].   For example+     type F :: Type -> forall (b :: Type) -> Type+     data family F a b+     newtype instance F Int b = MkF (Proxy b)+  we get a newtype, and a eta-reduced axiom connecting the data family+  with the newtype:+     type R:FIntb :: forall (b :: Type) -> Type+     newtype R:FIntb b = MkF (Proxy b)+     axiom Foo.D:R:FIntb0 :: F Int = Foo.R:FIntb+  Now the subtleties of Note [Newtype eta and homogeneous axioms] are+  dealt with by the newtype (via mkNewTyConRhs called in tcDataFamInstDecl)+  while the axiom connecting F Int ~ R:FIntb is eta-reduced, but the+  quantifer 'b' is derived from the original data family F, and so the+  kinds will always match.+ Note [Kind inference for data family instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this GADT-style data type declaration, where I have used@@ -1250,8 +1266,8 @@                      --    con_app_tys  = MkD ty1 ty2                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2-             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)-                                  (HsConLikeOut noExtField (RealDataCon dict_constr))+             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys) $+                            mkConLikeTc (RealDataCon dict_constr)                        -- NB: We *can* have covars in inst_tys, in the case of                        -- promoted GADT constructors.
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -65,8 +65,6 @@ import Control.Monad ( zipWithM ) import Data.List( partition, mapAccumL ) -#include "GhclibHsVersions.h"- {- ************************************************************************ *                                                                      *@@ -408,7 +406,7 @@        -- See Note [Checking against a pattern signature]        ; req_dicts <- newEvVars skol_req_theta        ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <--           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )+           assertPpr (equalLength arg_names arg_tys) (ppr name $$ ppr arg_names $$ ppr arg_tys) $            pushLevelAndCaptureConstraints   $            tcExtendNameTyVarEnv univ_tv_prs $            tcCheckPat PatSyn lpat (unrestricted skol_pat_ty)   $@@ -959,7 +957,7 @@ patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType) patSynBuilderOcc ps   | Just (_, builder_ty, add_void_arg) <- patSynBuilder ps-  , let builder_expr = HsConLikeOut noExtField (PatSynCon ps)+  , let builder_expr = mkConLikeTc (PatSynCon ps)   = Just $     if add_void_arg     then ( builder_expr   -- still just return builder_expr; the void# arg@@ -1025,7 +1023,7 @@         = return $ HsVar noExtField (L l var)         | otherwise         = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")-    go1 (ParPat _ pat)          = fmap (HsPar noAnn) $ go pat+    go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat     go1 p@(ListPat reb pats)       | Nothing <- reb = do { exprs <- mapM go pats                             ; return $ ExplicitList noExtField exprs }@@ -1203,7 +1201,7 @@     go1 :: Pat GhcTc -> ([TyVar], [EvVar])     go1 (LazyPat _ p)      = go p     go1 (AsPat _ _ p)      = go p-    go1 (ParPat _ p)       = go p+    go1 (ParPat _ _ p _)   = go p     go1 (BangPat _ p)      = go p     go1 (ListPat _ ps)     = mergeMany . map go $ ps     go1 (TuplePat _ ps _)  = mergeMany . map go $ ps@@ -1225,7 +1223,7 @@       = mergeMany . map goRecFd $ flds      goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])-    goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p+    goRecFd (L _ HsFieldBind{ hfbRHS = p }) = go p      merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)     mergeMany = foldr merge empty
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} @@ -27,8 +27,6 @@         tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Tc.Utils.Monad@@ -55,6 +53,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.FV as FV @@ -153,7 +152,7 @@      go_prov (PhantomProv co)     = go_co co      go_prov (ProofIrrelProv co)  = go_co co      go_prov (PluginProv _)       = emptyNameEnv-     go_prov CorePrepProv         = emptyNameEnv+     go_prov (CorePrepProv _)     = emptyNameEnv       go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc               | otherwise             = emptyNameEnv@@ -715,21 +714,21 @@  setRoleInferenceTc :: Name -> RoleM a -> RoleM a setRoleInferenceTc name thing = RM $ \m_name vps nvps state ->-                                ASSERT( isNothing m_name )-                                ASSERT( isEmptyVarEnv vps )-                                ASSERT( nvps == 0 )+                                assert (isNothing m_name) $+                                assert (isEmptyVarEnv vps) $+                                assert (nvps == 0) $                                 unRM thing (Just name) vps nvps state  addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a addRoleInferenceVar tv thing   = RM $ \m_name vps nvps state ->-    ASSERT( isJust m_name )+    assert (isJust m_name) $     unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state  setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a setRoleInferenceVars tvs thing   = RM $ \m_name _vps _nvps state ->-    ASSERT( isJust m_name )+    assert (isJust m_name) $     unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars")          state @@ -888,7 +887,7 @@      -- Find a representative constructor, con1     cons_w_field = conLikesWithFields all_cons [lbl]-    con1 = ASSERT( not (null cons_w_field) ) head cons_w_field+    con1 = assert (not (null cons_w_field)) $ head cons_w_field      -- Selector type; Note [Polymorphic selectors]     field_ty   = conLikeFieldType con1 lbl@@ -921,14 +920,14 @@                                  (L loc' (HsVar noExtField (L locn field_var)))     mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields)     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }-    rec_field  = noLocA (HsRecField-                        { hsRecFieldAnn = noAnn-                        , hsRecFieldLbl+    rec_field  = noLocA (HsFieldBind+                        { hfbAnn = noAnn+                        , hfbLHS                            = L loc (FieldOcc sel_name                                      (L locn $ mkVarUnqual lbl))-                        , hsRecFieldArg+                        , hfbRHS                            = L loc' (VarPat noExtField (L locn field_var))-                        , hsRecPun = False })+                        , hfbPun = False })     sel_lname = L locn sel_name     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                      #-}+ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables      #-} {-# LANGUAGE TypeFamilies             #-}@@ -76,10 +76,10 @@ import GHC.Tc.Errors import GHC.Tc.Utils.Unify -import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Data.FastString import GHC.Data.Maybe@@ -89,8 +89,6 @@  import {-# SOURCE #-} GHC.Tc.Module -#include "GhclibHsVersions.h"- fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc fixityMisMatch real_thing real_fixity sig_fixity =     vcat [ppr real_thing <+> text "has conflicting fixities in the module",@@ -1060,8 +1058,8 @@     -- TODO: setup the local RdrEnv so the error messages look a little better.     -- But this information isn't stored anywhere. Should we RETYPECHECK     -- the local one just to get the information?  Hmm...-    MASSERT( isHomeModule home_unit outer_mod )-    MASSERT( isHomeUnitInstantiating home_unit)+    massert (isHomeModule home_unit outer_mod )+    massert (isHomeUnitInstantiating home_unit)     let uid = Indefinite (homeUnitInstanceOf home_unit)     inner_mod `checkImplements`         Module
compiler/GHC/Tc/Utils/Env.hs view
@@ -1,5 +1,5 @@ -- (c) The University of Glasgow 2006-{-# LANGUAGE CPP, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an                                        -- orphan@@ -69,8 +69,6 @@         mkStableIdFromString, mkStableIdFromName,         mkWrapperName   ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -38,8 +38,6 @@      tyCoVarsOfCt, tyCoVarsOfCts,   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -85,6 +83,7 @@  import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable  import GHC.Unit.State@@ -124,7 +123,7 @@         ; let ty = piResultTys (idType id) ty_args              (theta, _caller_knows_this) = tcSplitPhiTy ty-       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )+       ; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $                  instCall origin ty_args theta         ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) }@@ -397,7 +396,7 @@   | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty))     -- Equality is the *only* constraint currently handled in types.     -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep-  = ASSERT( af == InvisArg )+  = assert (af == InvisArg) $     do { co <- unifyKind Nothing k1 k2        ; arg' <- mk co        ; return (subst, arg') }
compiler/GHC/Tc/Utils/Monad.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE CPP               #-} {-# LANGUAGE ExplicitForAll    #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards   #-}@@ -93,7 +92,7 @@   failWithTc, failWithTcM,   checkTc, checkTcM,   failIfTc, failIfTcM,-  warnIfFlag, warnIf, diagnosticTc, diagnosticTcM,+  warnIfFlag, warnIf, diagnosticTc, diagnosticTcM, addDetailedDiagnostic, addTcRnDiagnostic,   addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt, add_diagnostic,   mkErrInfo, @@ -148,8 +147,6 @@   module GHC.Data.IOEnv   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  @@ -188,8 +185,10 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Error import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Utils.Logger+import qualified GHC.Data.Strict as Strict  import GHC.Types.Error import GHC.Types.Fixity.Env@@ -898,7 +897,7 @@  getSrcSpanM :: TcRn SrcSpan         -- Avoid clash with Name.getSrcLoc-getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) }+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) }  -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool@@ -1040,7 +1039,7 @@          let msg' = pprWithUnitState unit_state msg in          return $ mkErrorMsgEnvelope loc printer                 $ TcRnUnknownMessage-                $ mkDecoratedError [msg', extra] }+                $ mkDecoratedError noHints [msg', extra] }  mkTcRnMessage :: DiagnosticReason               -> SrcSpan@@ -1060,7 +1059,7 @@          in          return $ mkMsgEnvelope dflags loc printer                 $ TcRnUnknownMessage-                $ mkDecoratedDiagnostic reason errDocs }+                $ mkDecoratedDiagnostic reason noHints errDocs }  addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic@@ -1550,6 +1549,25 @@ addDiagnostic :: DiagnosticReason -> SDoc -> TcRn () addDiagnostic reason msg = add_diagnostic reason msg Outputable.empty +-- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'+-- given some additional context about the diagnostic.+addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()+addDetailedDiagnostic mkMsg = do+  loc <- getSrcSpanM+  printer <- getPrintUnqualified+  dflags  <- getDynFlags+  env0 <- tcInitTidyEnv+  ctxt <- getErrCtxt+  err_info <- mkErrInfo env0 ctxt+  reportDiagnostic (mkMsgEnvelope dflags loc printer (mkMsg (ErrInfo err_info)))++addTcRnDiagnostic :: TcRnMessage -> TcM ()+addTcRnDiagnostic msg = do+  loc <- getSrcSpanM+  printer <- getPrintUnqualified+  dflags  <- getDynFlags+  reportDiagnostic (mkMsgEnvelope dflags loc printer msg)+ -- | Display a diagnostic for a given source location. addDiagnosticAt :: DiagnosticReason -> SrcSpan -> SDoc -> TcRn () addDiagnosticAt reason loc msg = add_diagnostic_at reason loc msg Outputable.empty@@ -1568,7 +1586,7 @@          dflags  <- getDynFlags ;          let { dia = mkMsgEnvelope dflags loc printer $                      TcRnUnknownMessage $-                     mkDecoratedDiagnostic reason [msg, extra_info] } ;+                     mkDecoratedDiagnostic reason noHints [msg, extra_info] } ;          reportDiagnostic dia }
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP             #-}+ {-# LANGUAGE MultiWayIf      #-} {-# LANGUAGE TupleSections   #-} @@ -96,8 +96,6 @@   ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr   ) where -#include "GhclibHsVersions.h"- -- friends: import GHC.Prelude @@ -127,6 +125,8 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.Pair@@ -337,15 +337,13 @@  -- | Put a value in a coercion hole fillCoercionHole :: CoercionHole -> Coercion -> TcM ()-fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co-  = do {-#if defined(DEBUG)-       ; cts <- readTcRef ref-       ; whenIsJust cts $ \old_co ->-         pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)-#endif-       ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)-       ; writeTcRef ref (Just co) }+fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do+  when debugIsOn $ do+    cts <- readTcRef ref+    whenIsJust cts $ \old_co ->+      pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)+  traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)+  writeTcRef ref (Just co)  -- | Is a coercion hole filled in? isFilledCoercionHole :: CoercionHole -> TcM Bool@@ -374,10 +372,10 @@   = do { cv_ty <- zonkTcType (varType cv)                   -- co is already zonked, but cv might not be        ; return $-         ASSERT2( ok cv_ty-                , (text "Bad coercion hole" <+>-                   ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role-                                            , ppr cv_ty ]) )+         assertPpr (ok cv_ty)+                   (text "Bad coercion hole" <+>+                    ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role+                                             , ppr cv_ty ])          co }   | otherwise   = return co@@ -906,7 +904,7 @@  cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv-  = ASSERT( isTcTyVar tv )+  = assert (isTcTyVar tv) $     do  { ref  <- newMutVar Flexi         ; name' <- cloneMetaTyVarName (tyVarName tv)         ; let details' = case tcTyVarDetails tv of@@ -918,7 +916,7 @@  -- Works for both type and kind variables readMetaTyVar :: TyVar -> TcM MetaDetails-readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )+readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $                       readMutVar (metaTyVarRef tyvar)  isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type)@@ -955,15 +953,13 @@  -- Everything from here on only happens if DEBUG is on   | not (isTcTyVar tyvar)-  = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar )-    return ()+  = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar)    | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar   = writeMetaTyVarRef tyvar ref ty    | otherwise-  = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar )-    return ()+  = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar)  -------------------- writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()@@ -1000,13 +996,13 @@        ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)         -- Check for double updates-       ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )+       ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details)         -- Check for level OK-       ; MASSERT2( level_check_ok, level_check_msg )+       ; massertPpr level_check_ok level_check_msg         -- Check Kinds ok-       ; MASSERT2( kind_check_ok, kind_msg )+       ; massertPpr kind_check_ok kind_msg         -- Do the write        ; writeMutVar ref (Indirect ty) }@@ -1534,7 +1530,7 @@     go_prov dv (PhantomProv co)    = go_co dv co     go_prov dv (ProofIrrelProv co) = go_co dv co     go_prov dv (PluginProv _)      = return dv-    go_prov dv CorePrepProv        = return dv+    go_prov dv (CorePrepProv _)    = return dv      go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs     go_cv dv@(DV { dv_cvs = cvs }) cv@@ -1714,7 +1710,7 @@         -- We should never quantify over coercion variables; check this        ; let co_vars = filter isCoVar final_qtvs-       ; MASSERT2( null co_vars, ppr co_vars )+       ; massertPpr (null co_vars) (ppr co_vars)         ; return final_qtvs }   where@@ -1757,7 +1753,7 @@        ; skolemiseQuantifiedTyVar zonked_tyvar }    | otherwise-  = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )+  = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $     zonkTyCoVarKind tyvar  skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar@@ -1869,7 +1865,7 @@ -- We create a skolem TcTyVar, not a regular TyVar --   See Note [Zonking to Skolem] skolemiseUnboundMetaTyVar tv-  = ASSERT2( isMetaTyVar tv, ppr tv )+  = assertPpr (isMetaTyVar tv) (ppr tv) $     do  { when debugIsOn (check_empty tv)         ; here <- getSrcSpanM    -- Get the location from "here"                                  -- ie where we are generalising@@ -1894,7 +1890,7 @@         do { cts <- readMetaTyVar tv            ; case cts of                Flexi       -> return ()-               Indirect ty -> WARN( True, ppr tv $$ ppr ty )+               Indirect ty -> warnPprTrace True (ppr tv $$ ppr ty) $                               return () }  {- Note [Error on unconstrained meta-variables]@@ -2199,7 +2195,7 @@ -- Also returns either the original tyvar (no promotion) or the new one -- See Note [Promoting unification variables] promoteMetaTyVarTo tclvl tv-  | ASSERT2( isMetaTyVar tv, ppr tv )+  | assertPpr (isMetaTyVar tv) (ppr tv) $     tcTyVarLevel tv `strictlyDeeperThan` tclvl   = do { cloned_tv <- cloneMetaTyVar tv        ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl@@ -2240,7 +2236,7 @@ -- Works on TyVars and TcTyVars zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv                | isTyVar   tv = mkTyVarTy <$> zonkTyCoVarKind tv-               | otherwise    = ASSERT2( isCoVar tv, ppr tv )+               | otherwise    = assertPpr (isCoVar tv) (ppr tv) $                                 mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv    -- Hackily, when typechecking type and class decls    -- we have TyVars in scope added (only) in
compiler/GHC/Tc/Utils/Unify.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-}@@ -41,8 +41,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs@@ -73,6 +71,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Exts      ( inline ) import Control.Monad@@ -107,7 +106,7 @@ -- and NB: res_ty is an (uninstantiated) SigmaType  matchActualFunTySigma herald mb_thing err_info fun_ty-  = ASSERT2( isRhoTy fun_ty, ppr fun_ty )+  = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $     go fun_ty   where     -- Does not allocate unnecessary meta variables: if the input already is@@ -122,7 +121,7 @@     go ty | Just ty' <- tcView ty = go ty'      go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })-      = ASSERT( af == VisArg )+      = assert (af == VisArg) $         return (idHsWrapper, Scaled w arg_ty, res_ty)      go ty@(TyVarTy tv)@@ -323,7 +322,7 @@       | Just ty' <- tcView ty = go acc_arg_tys n ty'      go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty })-      = ASSERT( af == VisArg )+      = assert (af == VisArg) $         do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)                                       (n-1) res_ty            ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc@@ -419,7 +418,7 @@ -- Postcondition: (T k1 k2 k3 a b c) is well-kinded  matchExpectedTyConApp tc orig_ty-  = ASSERT(not $ isFunTyCon tc) go orig_ty+  = assert (not $ isFunTyCon tc) $ go orig_ty   where     go ty        | Just ty' <- tcView ty@@ -542,7 +541,7 @@ -- rho-type, so nothing to instantiate; just go straight to unify. -- It means we don't need to pass in a CtOrigin tcWrapResultMono rn_expr expr act_ty res_ty-  = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr )+  = assertPpr (isRhoTy act_ty) (ppr act_ty $$ ppr rn_expr) $     do { co <- unifyExpectedType rn_expr act_ty res_ty        ; return (mkHsWrapCo co expr) } @@ -1014,7 +1013,7 @@   = return (emptyBag, emptyTcEvBinds)    | otherwise-  = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )+  = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $       -- Why allow TyVarTvs? Because implicitly declared kind variables in       -- non-CUSK type declarations are TyVarTvs, and we need to bring them       -- into scope as a skolem in an implication. This is OK, though,@@ -1225,7 +1224,7 @@     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)       -- See Note [Mismatched type lists and application decomposition]       | tc1 == tc2, equalLength tys1 tys2-      = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )+      = assertPpr (isGenerativeTyCon tc1 Nominal) (ppr tc1) $         do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2            ; return $ mkTyConAppCo Nominal tc1 cos }       where@@ -1244,12 +1243,12 @@      go (AppTy s1 t1) (TyConApp tc2 ts2)       | Just (ts2', t2') <- snocView ts2-      = ASSERT( not (mustBeSaturated tc2) )+      = assert (not (mustBeSaturated tc2)) $         go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'      go (TyConApp tc1 ts1) (AppTy s2 t2)       | Just (ts1', t1') <- snocView ts1-      = ASSERT( not (mustBeSaturated tc1) )+      = assert (not (mustBeSaturated tc1)) $         go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2      go (CoercionTy co1) (CoercionTy co2)@@ -1523,7 +1522,7 @@ --        => more likely to be eliminated -- See Note [TyVar/TyVar orientation] lhsPriority tv-  = ASSERT2( isTyVar tv, ppr tv)+  = assertPpr (isTyVar tv) (ppr tv) $     case tcTyVarDetails tv of       RuntimeUnk  -> 0       SkolemTv {} -> 0@@ -1567,7 +1566,7 @@    between levels 'n' and 'l'.     Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)?-   Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.Monad+   Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet  3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs    This precondition looks at the MetaInfo of the unification variable:@@ -1609,7 +1608,7 @@    * In the constraint solver, we track where Given equalities occur     and use that to guard unification in GHC.Tc.Solver.Canonical.unifyTest-    More details in Note [Tracking Given equalities] in GHC.Tc.Solver.Monad+    More details in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet      Historical note: in the olden days (pre 2021) the constraint solver     also used to unify only if l=n.  Equalities were "floated" out of the@@ -1705,7 +1704,7 @@   Otherwise it can't.  By putting the deepest variable on the left   we maximise our changes of eliminating skolem capture. -  See also GHC.Tc.Solver.Monad Note [Let-bound skolems] for another reason+  See also GHC.Tc.Solver.InertSet Note [Let-bound skolems] for another reason   to orient with the deepest skolem on the left.    IMPORTANT NOTE: this test does a level-number comparison on
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies     #-} @@ -43,8 +43,6 @@         lookupTyVarOcc   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -73,6 +71,8 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn)  import GHC.Core.Multiplicity import GHC.Core@@ -112,7 +112,7 @@ hsLPatType (L _ p) = hsPatType p  hsPatType :: Pat GhcTc -> Type-hsPatType (ParPat _ pat)                = hsLPatType pat+hsPatType (ParPat _ _ pat _)            = hsLPatType pat hsPatType (WildPat ty)                  = ty hsPatType (VarPat _ lvar)               = idType (unLoc lvar) hsPatType (BangPat _ pat)               = hsLPatType pat@@ -506,7 +506,7 @@ -- as the old one.  This important when zonking the -- TyVarBndrs of a TyCon, whose Names may scope. zonkTyBndrX env tv-  = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )+  = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $     do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)                -- Internal names tidy up better, for iface files.        ; let tv' = mkTyVar (tyVarName tv) ki@@ -628,7 +628,7 @@                         , abs_exports = exports                         , abs_binds = val_binds                         , abs_sig = has_sig })-  = ASSERT( all isImmutableTyVar tyvars )+  = assert (all isImmutableTyVar tyvars) $     do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars        ; (env1, new_evs) <- zonkEvBndrsX env0 evs        ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds@@ -792,7 +792,7 @@ zonkLExpr  env expr  = wrapLocMA (zonkExpr env) expr  zonkExpr env (HsVar x (L l id))-  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )+  = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $     return (HsVar x (L l (zonkIdOcc env id)))  zonkExpr env (HsUnboundVar her occ)@@ -805,12 +805,8 @@            ty'  <- zonkTcTypeToTypeX env ty            return (HER ref ty' u) -zonkExpr env (HsRecFld _ (Ambiguous v occ))-  = return (HsRecFld noExtField (Ambiguous (zonkIdOcc env v) occ))-zonkExpr env (HsRecFld _ (Unambiguous v occ))-  = return (HsRecFld noExtField (Unambiguous (zonkIdOcc env v) occ))--zonkExpr _ e@(HsConLikeOut {}) = return e+zonkExpr env (HsRecSel _ (FieldOcc v occ))+  = return (HsRecSel noExtField (FieldOcc (zonkIdOcc env v) occ))  zonkExpr _ (HsIPVar x id)   = return (HsIPVar x id)@@ -879,9 +875,9 @@        new_expr <- zonkLExpr env' expr        return (NegApp x new_expr new_op) -zonkExpr env (HsPar x e)+zonkExpr env (HsPar x lpar e rpar)   = do new_e <- zonkLExpr env e-       return (HsPar x new_e)+       return (HsPar x lpar new_e rpar)  zonkExpr env (SectionL x expr op)   = do new_expr <- zonkLExpr env expr@@ -1009,6 +1005,14 @@ zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b)))   = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b +zonkExpr env (XExpr (ConLikeTc con tvs tys))+  = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys+  where+    zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m <*> pure ty+    -- Only the multiplicity can contain unification variables+    -- The tvs come straight from the data-con, and so are strictly redundant+    -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head+ zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)  -------------------------------------------------------------------------@@ -1077,9 +1081,9 @@   = do new_matches <- zonkMatchGroup env zonkLCmd matches        return (HsCmdLam x new_matches) -zonkCmd env (HsCmdPar x c)+zonkCmd env (HsCmdPar x lpar c rpar)   = do new_c <- zonkLCmd env c-       return (HsCmdPar x new_c)+       return (HsCmdPar x lpar new_c rpar)  zonkCmd env (HsCmdCase x expr ms)   = do new_expr <- zonkLExpr env expr@@ -1119,7 +1123,7 @@        new_ty <- zonkTcTypeToTypeX env ty        new_ids <- mapSndM (zonkExpr env) ids -       MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) )+       massert (isLiftedTypeKind (tcTypeKind new_stack_tys))          -- desugarer assumes that this is not levity polymorphic...          -- but indeed it should always be lifted due to the typing          -- rules for arrows@@ -1142,7 +1146,7 @@                                  ; return (env', WpEvLam ev') } zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg                                  ; return (env, WpEvApp arg') }-zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )+zonkCoFn env (WpTyLam tv)   = assert (isImmutableTyVar tv) $                               do { (env', tv') <- zonkTyBndrX env tv                                  ; return (env', WpTyLam tv') } zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToTypeX env ty@@ -1371,10 +1375,10 @@         ; return (HsRecFields flds' dd) }   where     zonk_rbind (L l fld)-      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)-           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)-           ; return (L l (fld { hsRecFieldLbl = new_id-                              , hsRecFieldArg = new_expr })) }+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hfbLHS fld)+           ; new_expr <- zonkLExpr env (hfbRHS fld)+           ; return (L l (fld { hfbLHS = new_id+                              , hfbRHS = new_expr })) }  zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc]                  -> TcM [LHsRecUpdField GhcTc]@@ -1382,9 +1386,9 @@   where     zonk_rbind (L l fld)       = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)-           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)-           ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id-                              , hsRecFieldArg = new_expr })) }+           ; new_expr <- zonkLExpr env (hfbRHS fld)+           ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id+                              , hfbRHS = new_expr })) }  ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a@@ -1408,9 +1412,9 @@ zonkPat env pat = wrapLocSndMA (zonk_pat env) pat  zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc)-zonk_pat env (ParPat x p)+zonk_pat env (ParPat x lpar p rpar)   = do  { (env', p') <- zonkPat env p-        ; return (env', ParPat x p') }+        ; return (env', ParPat x lpar p' rpar) }  zonk_pat env (WildPat ty)   = do  { ty' <- zonkTcTypeToTypeX env ty@@ -1473,7 +1477,7 @@                          , cpt_arg_tys = tys                          })                        })-  = ASSERT( all isImmutableTyVar tyvars )+  = assert (all isImmutableTyVar tyvars) $     do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys            -- an unboxed tuple pattern (but only an unboxed tuple pattern)@@ -1557,9 +1561,9 @@         ; return (env', InfixCon p1' p2') }  zonkConStuff env (RecCon (HsRecFields rpats dd))-  = do  { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)+  = do  { (env', pats') <- zonkPats env (map (hfbRHS . unLoc) rpats)         ; let rpats' = zipWith (\(L l rp) p' ->-                                  L l (rp { hsRecFieldArg = p' }))+                                  L l (rp { hfbRHS = p' }))                                rpats pats'         ; return (env', RecCon (HsRecFields rpats' dd)) }         -- Field selectors have declared types; hence no zonking@@ -1620,7 +1624,7 @@    zonk_it env v      | isId v     = do { v' <- zonkIdBndr env v                        ; return (extendIdZonkEnvRec env [v'], v') }-     | otherwise  = ASSERT( isImmutableTyVar v)+     | otherwise  = assert (isImmutableTyVar v)                     zonkTyBndrX env v                     -- DV: used to be return (env,v) but that is plain                     -- wrong because we may need to go inside the kind@@ -1954,9 +1958,9 @@            Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)                          ; when debugIsOn $                            whenNoErrs $-                           MASSERT2( False-                                   , text "Type-correct unfilled coercion hole"-                                     <+> ppr hole )+                           massertPpr False+                                      (text "Type-correct unfilled coercion hole"+                                       <+> ppr hole)                          ; cv' <- zonkCoVar cv                          ; return $ mkCoVarCo cv' } }                              -- This will be an out-of-scope variable, but keeping
compiler/GHC/Tc/Validity.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP           #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} @@ -20,8 +20,6 @@   allDistinctTyVars   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Data.Maybe@@ -808,7 +806,7 @@     check_args_only expand = mapM_ (check_arg expand) tys      check_expansion_only expand-      = ASSERT2( isTypeSynonymTyCon tc, ppr tc )+      = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $         case tcView ty of          Just ty' -> let err_ctxt = text "In the expansion of type synonym"                                     <+> quotes (ppr tc)
compiler/GHC/ThToHs.hs view
@@ -253,7 +253,7 @@         ; ksig' <- cvtKind `traverse` ksig         ; cons' <- mapM cvtConstr constrs         ; derivs' <- cvtDerivs derivs-        ; let defn = HsDataDefn { dd_ext = noAnn+        ; let defn = HsDataDefn { dd_ext = noExtField                                 , dd_ND = DataType, dd_cType = Nothing                                 , dd_ctxt = Just ctxt'                                 , dd_kindSig = ksig'@@ -269,7 +269,7 @@         ; ksig' <- cvtKind `traverse` ksig         ; con' <- cvtConstr constr         ; derivs' <- cvtDerivs derivs-        ; let defn = HsDataDefn { dd_ext = noAnn+        ; let defn = HsDataDefn { dd_ext = noExtField                                 , dd_ND = NewType, dd_cType = Nothing                                 , dd_ctxt = Just ctxt'                                 , dd_kindSig = ksig'@@ -340,7 +340,7 @@        ; ksig' <- cvtKind `traverse` ksig        ; cons' <- mapM cvtConstr constrs        ; derivs' <- cvtDerivs derivs-       ; let defn = HsDataDefn { dd_ext = noAnn+       ; let defn = HsDataDefn { dd_ext = noExtField                                , dd_ND = DataType, dd_cType = Nothing                                , dd_ctxt = Just ctxt'                                , dd_kindSig = ksig'@@ -361,7 +361,7 @@        ; ksig' <- cvtKind `traverse` ksig        ; con' <- cvtConstr constr        ; derivs' <- cvtDerivs derivs-       ; let defn = HsDataDefn { dd_ext = noAnn+       ; let defn = HsDataDefn { dd_ext = noExtField                                , dd_ND = NewType, dd_cType = Nothing                                , dd_ctxt = Just ctxt'                                , dd_kindSig = ksig'@@ -874,7 +874,7 @@ cvtRuleBndr (TypedRuleVar n ty)   = do { n'  <- vNameN n        ; ty' <- cvtType ty-       ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType ty' }+       ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }  --------------------------------------------------- --              Declarations@@ -933,7 +933,7 @@         go cvt_lit mk_expr is_compound_lit = do           l' <- cvt_lit l           let e' = mk_expr l'-          return $ if is_compound_lit l' then HsPar noAnn (noLocA e') else e'+          return $ if is_compound_lit l' then gHsPar (noLocA e') else e'     cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y                                    ; return $ HsApp noComments (mkLHsPar x')                                                           (mkLHsPar y')}@@ -998,7 +998,7 @@          ; y' <- cvtl y          ; let px = parenthesizeHsExpr opPrec x'                py = parenthesizeHsExpr opPrec y'-         ; wrapParLA (HsPar noAnn)+         ; wrapParLA gHsPar            $ OpApp noAnn px s' py }            -- Parenthesise both arguments and result,            -- to ensure this operator application does@@ -1006,17 +1006,17 @@            -- See Note [Operator association]     cvt (InfixE Nothing  s (Just y)) = ensureValidOpExp s $                                        do { s' <- cvtl s; y' <- cvtl y-                                          ; wrapParLA (HsPar noAnn) $+                                          ; wrapParLA gHsPar $                                                           SectionR noComments s' y' }                                             -- See Note [Sections in HsSyn] in GHC.Hs.Expr     cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $                                        do { x' <- cvtl x; s' <- cvtl s-                                          ; wrapParLA (HsPar noAnn) $+                                          ; wrapParLA gHsPar $                                                           SectionL noComments x' s' }      cvt (InfixE Nothing  s Nothing ) = ensureValidOpExp s $                                        do { s' <- cvtl s-                                          ; return $ HsPar noAnn s' }+                                          ; return $ gHsPar s' }                                        -- Can I indicate this is an infix thing?                                        -- Note [Dropping constructors] @@ -1027,7 +1027,7 @@                                             _ -> mkLHsPar x'                               ; cvtOpApp x'' s y } --  Note [Converting UInfix] -    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noAnn e' }+    cvt (ParensE e)      = do { e' <- cvtl e; return $ gHsPar e' }     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtSigType t                               ; let pe = parenthesizeHsExpr sigPrec e'                               ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }@@ -1082,13 +1082,13 @@ -}  cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)-       -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))+       -> CvtM (LHsFieldBind GhcPs (Located t) (LHsExpr GhcPs)) cvtFld f (v,e)   = do  { v' <- vNameL v; e' <- cvtl e-        ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn-                                      , hsRecFieldLbl = reLoc $ fmap f v'-                                      , hsRecFieldArg = e'-                                      , hsRecPun      = False}) }+        ; return (noLocA $ HsFieldBind { hfbAnn = noAnn+                                       , hfbLHS = reLoc $ fmap f v'+                                       , hfbRHS = e'+                                       , hfbPun = False}) }  cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }@@ -1208,7 +1208,7 @@ cvtMatch ctxt (TH.Match p body decs)   = do  { p' <- cvtPat p         ; let lp = case p' of-                     (L loc SigPat{}) -> L loc (ParPat noAnn p') -- #14875+                     (L loc SigPat{}) -> L loc (gParPat p') -- #14875                      _                -> p'         ; g' <- cvtGuard body         ; decs' <- cvtLocalDecs (text "a where clause") decs@@ -1318,11 +1318,11 @@                             ; return $ ConPat                                 { pat_con_ext = noAnn                                 , pat_con = s'-                                , pat_args = PrefixCon (map mkHsPatSigType ts') pps+                                , pat_args = PrefixCon (map (mkHsPatSigType noAnn) ts') pps                                 }                             } cvtp (InfixP p1 s p2)  = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2-                            ; wrapParLA (ParPat noAnn) $+                            ; wrapParLA gParPat $                               ConPat                                 { pat_con_ext = noAnn                                 , pat_con = s'@@ -1336,7 +1336,7 @@ cvtp (ParensP p)       = do { p' <- cvtPat p;                             ; case unLoc p' of  -- may be wrapped ConPatIn                                 ParPat {} -> return $ unLoc p'-                                _         -> return $ ParPat noAnn p' }+                                _         -> return $ gParPat p' } cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noAnn p' } cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noAnn p' } cvtp (TH.AsP s p)      = do { s' <- vNameN s; p' <- cvtPat p@@ -1353,7 +1353,7 @@                             ; return                                    $ ListPat noAnn ps'} cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t-                            ; return $ SigPat noAnn p' (mkHsPatSigType t') }+                            ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') } cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p                             ; return $ ViewPat noAnn e' p'} @@ -1361,11 +1361,11 @@ cvtPatFld (s,p)   = do  { L ls s' <- vNameN s         ; p' <- cvtPat p-        ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn-                                      , hsRecFieldLbl-                                         = L (locA ls) $ mkFieldOcc (L ls s')-                                      , hsRecFieldArg = p'-                                      , hsRecPun      = False}) }+        ; return (noLocA $ HsFieldBind { hfbAnn = noAnn+                                       , hfbLHS+                                          = L (locA ls) $ mkFieldOcc (L ls s')+                                       , hfbRHS = p'+                                       , hfbPun = False}) }  {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix patterns will be left-biased, provided @x@ is.@@ -1816,7 +1816,7 @@                                ; let l = noAnnSrcSpan l'                                ; ty' <- cvtType (ForallT exis provs ty)                                ; return $ L l $ mkHsImplicitSigType-                                        $ L l (HsQualTy { hst_ctxt = Nothing+                                        $ L l (HsQualTy { hst_ctxt = noLocA []                                                         , hst_xqual = noExtField                                                         , hst_body = ty' }) }   | null reqs             = do { l'      <- getL@@ -1824,7 +1824,7 @@                                ; univs' <- cvtTvs univs                                ; ty'    <- cvtType (ForallT exis provs ty)                                ; let forTy = mkHsExplicitSigType noAnn univs' $ L l'' cxtTy-                                     cxtTy = HsQualTy { hst_ctxt = Nothing+                                     cxtTy = HsQualTy { hst_ctxt = noLocA []                                                       , hst_xqual = noExtField                                                       , hst_body = ty' }                                ; return $ L (noAnnSrcSpan l') forTy }@@ -1910,7 +1910,7 @@ mkHsQualTy ctxt loc ctxt' ty   | null ctxt = ty   | otherwise = L loc $ HsQualTy { hst_xqual = noExtField-                                 , hst_ctxt  = Just ctxt'+                                 , hst_ctxt  = ctxt'                                  , hst_body  = ty }  mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
compiler/GHC/Types/Name/Shape.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.Types.Name.Shape    ( NameShape(..)    , emptyNameShape@@ -11,8 +11,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -29,8 +27,7 @@ import GHC.Iface.Env  import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad @@ -268,11 +265,11 @@ uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name           -> Either SDoc ShNameSubst uHoleName flexi subst h n =-    ASSERT( isHoleName h )+    assert (isHoleName h) $     case lookupNameEnv subst h of         Just n' -> uName flexi subst n' n                 -- Do a quick check if the other name is substituted.         Nothing | Just n' <- lookupNameEnv subst n ->-                    ASSERT( isHoleName n ) uName flexi subst h n'+                    assert (isHoleName n) $ uName flexi subst h n'                 | otherwise ->                     Right (extendNameEnv subst h n)
compiler/GHC/Types/TyThing/Ppr.hs view
@@ -6,7 +6,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-}+ module GHC.Types.TyThing.Ppr (         pprTyThing,         pprTyThingInContext,@@ -16,8 +16,6 @@         pprFamInst   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Ppr (warnPprTrace)@@ -167,7 +165,7 @@ -- | Pretty-prints a 'TyThing'. pprTyThing :: ShowSub -> TyThing -> SDoc -- We pretty-print 'TyThing' via 'IfaceDecl'--- See Note [Pretty-printing TyThings]+-- See Note [Pretty printing via Iface syntax] pprTyThing ss ty_thing   = sdocOption sdocLinearTypes $ \show_linear_types ->       pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)@@ -187,7 +185,7 @@          = case nameModule_maybe name of              Just mod -> Just $ \occ -> getPprStyle $ \sty ->                pprModulePrefix sty mod occ <> ppr occ-             Nothing  -> WARN( True, ppr name ) Nothing+             Nothing  -> warnPprTrace True (ppr name) Nothing              -- Nothing is unexpected here; TyThings have External names  showWithLoc :: SDoc -> SDoc -> SDoc
compiler/GHC/Unit/Finder.hs view
@@ -3,7 +3,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-}  -- | Module finder@@ -32,8 +32,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -362,7 +360,8 @@ -- for the appropriate config. findPackageModule_ :: FinderCache -> DynFlags -> InstalledModule -> UnitInfo -> IO InstalledFindResult findPackageModule_ fc dflags mod pkg_conf = do-  MASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )+  massertPpr (moduleUnit mod == unitId pkg_conf)+             (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))   modLocationCache fc mod $      -- special case for GHC.Prim; we won't find it in the filesystem.
− compiler/GhclibHsVersions.h 
@@ -1,56 +0,0 @@-#pragma once---- For GHC_STAGE-#include "ghcplatform.h"--#if 0--IMPORTANT!  If you put extra tabs/spaces in these macro definitions,-you will screw up the layout where they are used in case expressions!--(This is cpp-dependent, of course)--#endif--#define GLOBAL_VAR(name,value,ty)  \-{-# NOINLINE name #-};             \-name :: IORef (ty);                \-name = GHC.Utils.GlobalVars.global (value);--#define GLOBAL_VAR_M(name,value,ty) \-{-# NOINLINE name #-};              \-name :: IORef (ty);                 \-name = GHC.Utils.GlobalVars.globalM (value);---#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-};                                      \-name :: IORef (ty);                                         \-name = GHC.Utils.GlobalVars.sharedGlobal (value) (accessor);\-foreign import ccall unsafe saccessor                       \-  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));--#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \-{-# NOINLINE name #-};                                         \-name :: IORef (ty);                                            \-name = GHC.Utils.GlobalVars.sharedGlobalM (value) (accessor);  \-foreign import ccall unsafe saccessor                          \-  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));---#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else-#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $---- Examples:   Assuming   flagSet :: String -> m Bool------    do { c   <- getChar; MASSERT( isUpper c ); ... }---    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }---    do { str <- getStr;  ASSERTM( flagSet str ); .. }---    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }---    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }-#define MASSERT(e)      ASSERT(e) return ()-#define MASSERT2(e,msg) ASSERT2(e,msg) return ()-#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }-#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }-#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20210501+version: 0.20210601 license: BSD3 license-file: LICENSE category: Development@@ -40,7 +40,6 @@     includes/MachDeps.h     includes/stg/MachRegs.h     includes/CodeGen.Platform.hs-    compiler/GhclibHsVersions.h     compiler/Unique.h source-repository head     type: git@@ -79,7 +78,7 @@         hpc == 0.6.*,         exceptions == 0.10.*,         parsec,-        ghc-lib-parser == 0.20210501+        ghc-lib-parser == 0.20210601     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns@@ -209,6 +208,7 @@         GHC.Data.ShortText,         GHC.Data.SizedSeq,         GHC.Data.Stream,+        GHC.Data.Strict,         GHC.Data.StringBuffer,         GHC.Data.TrieMap,         GHC.Driver.Backend,@@ -271,7 +271,6 @@         GHC.Parser,         GHC.Parser.Annotation,         GHC.Parser.CharClass,-        GHC.Parser.Errors,         GHC.Parser.Errors.Ppr,         GHC.Parser.Errors.Types,         GHC.Parser.Header,@@ -332,6 +331,7 @@         GHC.Types.Fixity.Env,         GHC.Types.ForeignCall,         GHC.Types.ForeignStubs,+        GHC.Types.Hint,         GHC.Types.HpcInfo,         GHC.Types.IPE,         GHC.Types.Id,@@ -396,6 +396,7 @@         GHC.Utils.Binary.Typeable,         GHC.Utils.BufHandle,         GHC.Utils.CliOption,+        GHC.Utils.Constants,         GHC.Utils.Encoding,         GHC.Utils.Error,         GHC.Utils.Exception,@@ -731,9 +732,11 @@         GHC.Tc.Plugin         GHC.Tc.Solver         GHC.Tc.Solver.Canonical+        GHC.Tc.Solver.InertSet         GHC.Tc.Solver.Interact         GHC.Tc.Solver.Monad         GHC.Tc.Solver.Rewrite+        GHC.Tc.Solver.Types         GHC.Tc.TyCl         GHC.Tc.TyCl.Build         GHC.Tc.TyCl.Class
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -289,7 +289,7 @@   , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n     in the CNF. ")   , ("reallyUnsafePtrEquality#"," Returns @1\\#@ if the given pointers are equal and @0\\#@ otherwise. ")   , ("numSparks#"," Returns the number of sparks in the local spark pool. ")-  , ("keepAlive#"," TODO. ")+  , ("keepAlive#"," \\tt{keepAlive# x s k} keeps the value \\tt{x} alive during the execution\n     of the computation \\tt{k}. ")   , ("BCO"," Primitive bytecode type. ")   , ("addrToAny#"," Convert an @Addr\\#@ to a followable Any type. ")   , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an @unsafeCoerce\\#@, but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that @Addr\\#@ is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -233,6 +233,9 @@ /* Define to 1 if you have the Darwin version of pthread_setname_np */ #define HAVE_PTHREAD_SETNAME_NP_DARWIN 1 +/* Define to 1 if you have the NetBSD version of pthread_setname_np */+/* #undef HAVE_PTHREAD_SETNAME_NP_NETBSD */+ /* Define to 1 if you have pthread_set_name_np */ /* #undef HAVE_PTHREAD_SET_NAME_NP */
ghc-lib/stage0/lib/llvm-targets view
@@ -52,5 +52,6 @@ ,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))+,("aarch64-unknown-netbsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ]