packages feed

ghc-lib 9.12.3.20251228 → 9.14.1.20251220

raw patch · 277 files changed

+61733/−39293 lines, 277 filesdep ~basedep ~containersdep ~ghc-lib-parser

Dependency ranges changed: base, containers, ghc-lib-parser, time

Files

compiler/Bytecodes.h view
@@ -112,6 +112,109 @@  #define bci_PRIMCALL                    87 +#define bci_BCO_NAME                    88++#define bci_OP_ADD_64                   90+#define bci_OP_SUB_64                   91+#define bci_OP_AND_64                   92+#define bci_OP_XOR_64                   93+#define bci_OP_NOT_64                   94+#define bci_OP_NEG_64                   95+#define bci_OP_MUL_64                   96+#define bci_OP_SHL_64                   97+#define bci_OP_ASR_64                   98+#define bci_OP_LSR_64                   99+#define bci_OP_OR_64                   100++#define bci_OP_NEQ_64                  110+#define bci_OP_EQ_64                   111+#define bci_OP_U_GE_64                 112+#define bci_OP_U_GT_64                 113+#define bci_OP_U_LT_64                 114+#define bci_OP_U_LE_64                 115+#define bci_OP_S_GE_64                 116+#define bci_OP_S_GT_64                 117+#define bci_OP_S_LT_64                 118+#define bci_OP_S_LE_64                 119+++#define bci_OP_ADD_32                  130+#define bci_OP_SUB_32                  131+#define bci_OP_AND_32                  132+#define bci_OP_XOR_32                  133+#define bci_OP_NOT_32                  134+#define bci_OP_NEG_32                  135+#define bci_OP_MUL_32                  136+#define bci_OP_SHL_32                  137+#define bci_OP_ASR_32                  138+#define bci_OP_LSR_32                  139+#define bci_OP_OR_32                   140++#define bci_OP_NEQ_32                  150+#define bci_OP_EQ_32                   151+#define bci_OP_U_GE_32                 152+#define bci_OP_U_GT_32                 153+#define bci_OP_U_LT_32                 154+#define bci_OP_U_LE_32                 155+#define bci_OP_S_GE_32                 156+#define bci_OP_S_GT_32                 157+#define bci_OP_S_LT_32                 158+#define bci_OP_S_LE_32                 159+++#define bci_OP_ADD_16                  170+#define bci_OP_SUB_16                  171+#define bci_OP_AND_16                  172+#define bci_OP_XOR_16                  173+#define bci_OP_NOT_16                  174+#define bci_OP_NEG_16                  175+#define bci_OP_MUL_16                  176+#define bci_OP_SHL_16                  177+#define bci_OP_ASR_16                  178+#define bci_OP_LSR_16                  179+#define bci_OP_OR_16                   180++#define bci_OP_NEQ_16                  190+#define bci_OP_EQ_16                   191+#define bci_OP_U_GE_16                 192+#define bci_OP_U_GT_16                 193+#define bci_OP_U_LT_16                 194+#define bci_OP_U_LE_16                 195+#define bci_OP_S_GE_16                 196+#define bci_OP_S_GT_16                 197+#define bci_OP_S_LT_16                 198+#define bci_OP_S_LE_16                 199+++#define bci_OP_ADD_08                  200+#define bci_OP_SUB_08                  201+#define bci_OP_AND_08                  202+#define bci_OP_XOR_08                  203+#define bci_OP_NOT_08                  204+#define bci_OP_NEG_08                  205+#define bci_OP_MUL_08                  206+#define bci_OP_SHL_08                  207+#define bci_OP_ASR_08                  208+#define bci_OP_LSR_08                  209+#define bci_OP_OR_08                   210++#define bci_OP_NEQ_08                  220+#define bci_OP_EQ_08                   221+#define bci_OP_U_GE_08                 222+#define bci_OP_U_GT_08                 223+#define bci_OP_U_LT_08                 224+#define bci_OP_U_LE_08                 225+#define bci_OP_S_GE_08                 226+#define bci_OP_S_GT_08                 227+#define bci_OP_S_LT_08                 228+#define bci_OP_S_LE_08                 229++#define bci_OP_INDEX_ADDR_08           240+#define bci_OP_INDEX_ADDR_16           241+#define bci_OP_INDEX_ADDR_32           242+#define bci_OP_INDEX_ADDR_64           243++ /* If you need to go past 255 then you will run into the flags */  /* If you need to go below 0x0100 then you will run into the instructions */
compiler/ClosureTypes.h view
@@ -89,4 +89,5 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA                63 #define CONTINUATION                  64-#define N_CLOSURE_TYPES               65+#define ANN_FRAME                     65+#define N_CLOSURE_TYPES               66
compiler/CodeGen.Platform.h view
@@ -2,7 +2,7 @@ import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \     || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64) \-    || defined(MACHREGS_riscv64))+    || defined(MACHREGS_riscv64) || defined(MACHREGS_loongarch64)) import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg@@ -1032,11 +1032,15 @@ -- ip0 -- used for spill offset computations freeReg 16 = False -#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)+-- Note [Aarch64 Register x18 at Darwin and Windows]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- x18 is reserved by the platform on Darwin/iOS, and can not be used -- More about ARM64 ABI that Apple platforms support: -- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms -- https://github.com/Siguza/ios-resources/blob/master/bits/arm64.md+-- It is a reserved at Windows as well. Acts like TEB register in user mode at Windows.+-- https://learn.microsoft.com/en-us/cpp/build/arm64-windows-abi-conventions+#if defined(darwin_HOST_OS) || defined(ios_HOST_OS) || defined(mingw32_HOST_OS) freeReg 18 = False #endif @@ -1138,6 +1142,104 @@ -- made-up inter-procedural (ip) register -- See Note [The made-up RISCV64 TMP (IP) register] freeReg 31 = False++# if defined(REG_Base)+freeReg REG_Base  = False+# endif+# if defined(REG_Sp)+freeReg REG_Sp    = False+# endif+# if defined(REG_SpLim)+freeReg REG_SpLim = False+# endif+# if defined(REG_Hp)+freeReg REG_Hp    = False+# endif+# if defined(REG_HpLim)+freeReg REG_HpLim = False+# endif++# if defined(REG_R1)+freeReg REG_R1    = False+# endif+# if defined(REG_R2)+freeReg REG_R2    = False+# endif+# if defined(REG_R3)+freeReg REG_R3    = False+# endif+# if defined(REG_R4)+freeReg REG_R4    = False+# endif+# if defined(REG_R5)+freeReg REG_R5    = False+# endif+# if defined(REG_R6)+freeReg REG_R6    = False+# endif+# if defined(REG_R7)+freeReg REG_R7    = False+# endif+# if defined(REG_R8)+freeReg REG_R8    = False+# endif++# if defined(REG_F1)+freeReg REG_F1    = False+# endif+# if defined(REG_F2)+freeReg REG_F2    = False+# endif+# if defined(REG_F3)+freeReg REG_F3    = False+# endif+# if defined(REG_F4)+freeReg REG_F4    = False+# endif+# if defined(REG_F5)+freeReg REG_F5    = False+# endif+# if defined(REG_F6)+freeReg REG_F6    = False+# endif++# if defined(REG_D1)+freeReg REG_D1    = False+# endif+# if defined(REG_D2)+freeReg REG_D2    = False+# endif+# if defined(REG_D3)+freeReg REG_D3    = False+# endif+# if defined(REG_D4)+freeReg REG_D4    = False+# endif+# if defined(REG_D5)+freeReg REG_D5    = False+# endif+# if defined(REG_D6)+freeReg REG_D6    = False+# endif++freeReg _ = True++#elif defined(MACHREGS_loongarch64)++-- zero register+freeReg 0 = False+-- linker regster+freeReg 1 = False+-- thread register+freeReg 2 = False+-- stack pointer+freeReg 3 = False+-- made-up inter-procedural (ip) register for spilling offset computations+freeReg 20 = False+-- reserved+freeReg 21 = False+-- frame pointer+freeReg 22 = False  # if defined(REG_Base) freeReg REG_Base  = False
compiler/GHC.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE TupleSections, NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE LambdaCase #-}  -- ----------------------------------------------------------------------------- --@@ -37,7 +38,9 @@         setSessionDynFlags,         setUnitDynFlags,         getProgramDynFlags, setProgramDynFlags,+        setProgramHUG, setProgramHUG_,         getInteractiveDynFlags, setInteractiveDynFlags,+        normaliseInteractiveDynFlags, initialiseInteractiveDynFlags,         interpretPackageEnv,          -- * Logging@@ -54,6 +57,7 @@         addTarget,         removeTarget,         guessTarget,+        guessTargetId,          -- * Loading\/compiling the program         depanal, depanalE,@@ -82,6 +86,7 @@         getModuleGraph,         isLoaded,         isLoadedModule,+        isLoadedHomeModule,         topSortModuleGraph,          -- * Inspecting modules@@ -99,33 +104,37 @@         findGlobalAnns,         mkNamePprCtxForModule,         ModIface,-        ModIface_(-          mi_module,-          mi_sig_of,-          mi_hsc_src,-          mi_src_hash,-          mi_hi_bytes,-          mi_deps,-          mi_usages,-          mi_exports,-          mi_used_th,-          mi_fixities,-          mi_warns,-          mi_anns,-          mi_insts,-          mi_fam_insts,-          mi_rules,-          mi_decls,-          mi_extra_decls,-          mi_top_env,-          mi_hpc,-          mi_trust,-          mi_trust_pkg,-          mi_complete_matches,-          mi_docs,-          mi_final_exts,-          mi_ext_fields-        ),+        ModIface_( mi_mod_info+                 , mi_module+                 , mi_sig_of+                 , mi_hsc_src+                 , mi_iface_hash+                 , mi_deps+                 , mi_public+                 , mi_exports+                 , mi_fixities+                 , mi_warns+                 , mi_anns+                 , mi_decls+                 , mi_defaults+                 , mi_simplified_core+                 , mi_top_env+                 , mi_insts+                 , mi_fam_insts+                 , mi_rules+                 , mi_trust+                 , mi_trust_pkg+                 , mi_complete_matches+                 , mi_docs+                 , mi_abi_hashes+                 , mi_ext_fields+                 , mi_hi_bytes+                 , mi_self_recomp_info+                 , mi_fix_fn+                 , mi_decl_warn_fn+                 , mi_export_warn_fn+                 , mi_hash_fn+                 ),         pattern ModIface,         SafeHaskellMode(..), @@ -150,6 +159,7 @@         getBindings, getInsts, getNamePprCtx,         findModule, lookupModule,         findQualifiedModule, lookupQualifiedModule,+        lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames,         renamePkgQualM, renameRawPkgQualM,         isModuleTrusted, moduleTrustReqs,         getNamesInScope,@@ -191,7 +201,7 @@         getResumeContext,         GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,         modInfoModBreaks,-        ModBreaks(..), BreakIndex,+        ModBreaks(..), BreakTickIndex,         BreakpointId(..), InternalBreakpointId(..),         GHC.Runtime.Eval.back,         GHC.Runtime.Eval.forward,@@ -336,6 +346,7 @@ import GHC.Driver.Errors.Types import GHC.Driver.CmdLine import GHC.Driver.Session+import GHC.Driver.Session.Inspect import GHC.Driver.Backend import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts)@@ -368,7 +379,7 @@ import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)+import GHC.Rename.Names (renamePkgQual, renameRawPkgQual)  import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types@@ -415,15 +426,11 @@ import GHC.Types.Basic import GHC.Types.TyThing import GHC.Types.Name.Env-import GHC.Types.Name.Ppr import GHC.Types.TypeEnv-import GHC.Types.Breakpoint import GHC.Types.PkgQual-import GHC.Types.Unique.FM  import GHC.Unit-import GHC.Unit.Env-import GHC.Unit.External+import GHC.Unit.Env as UnitEnv import GHC.Unit.Finder import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModGuts@@ -431,6 +438,7 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo+import qualified GHC.Unit.Home.Graph as HUG import GHC.Settings  import Control.Applicative ((<|>))@@ -438,6 +446,7 @@ import Control.Monad import Control.Monad.Catch as MC import Data.Foldable+import Data.Function ((&)) import Data.IORef import Data.List (isPrefixOf) import Data.Typeable    ( Typeable )@@ -454,6 +463,7 @@ import System.FilePath import System.IO.Error  ( isDoesNotExistError ) + -- %************************************************************************ -- %*                                                                      * --             Initialisation: exception handlers@@ -482,6 +492,8 @@                          liftIO $ throwIO UserInterrupt                      Just StackOverflow ->                          fm "stack overflow: use +RTS -K<size> to increase it"+                     Just HeapOverflow ->+                         fm "heap overflow: use +RTS -M<size> to increase maximum heap size"                      _ -> case fromException exception of                           Just (ex :: ExitCode) -> liftIO $ throwIO ex                           _ ->@@ -664,7 +676,7 @@           , homeUnitEnv_home_unit = Just home_unit           } -  let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)+  let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)    let dflags = updated_dflags @@ -682,7 +694,7 @@   let !unit_env1 =         if homeUnitId_ dflags /= uid           then-            ue_renameUnitId+            UnitEnv.renameUnitId                   uid                   (homeUnitId_ dflags)                   unit_env0@@ -700,9 +712,9 @@ setTopSessionDynFlags dflags = do   hsc_env <- getSession   logger  <- getLogger-  lookup_cache  <- liftIO $ newMVar emptyUFM+  lookup_cache  <- liftIO $ mkInterpSymbolCache -  -- Interpreter+  -- see Note [Target code interpreter]   interp <- if     -- Wasm dynamic linker     | ArchWasm32 <- platformArch $ targetPlatform dflags@@ -722,10 +734,17 @@                 { wasmInterpDyLD = dyld,                   wasmInterpLibDir = libdir,                   wasmInterpOpts = getOpts dflags opt_i,+                  wasmInterpBrowser = gopt Opt_GhciBrowser dflags,+                  wasmInterpBrowserHost = ghciBrowserHost dflags,+                  wasmInterpBrowserPort = ghciBrowserPort dflags,+                  wasmInterpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags,+                  wasmInterpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags,+                  wasmInterpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags,+                  wasmInterpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags,                   wasmInterpTargetPlatform = targetPlatform dflags,                   wasmInterpProfiled = profiled,                   wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (ghcNameVersion dflags),-                  wasmInterpUnitState = ue_units $ hsc_unit_env hsc_env+                  wasmInterpUnitState = ue_homeUnitState $ hsc_unit_env hsc_env                 }         pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache @@ -819,7 +838,7 @@           let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv               dflags = homeUnitEnv_dflags homeUnitEnv               old_hpt = homeUnitEnv_hpt homeUnitEnv-              home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)+              home_units = HUG.allUnits (ue_home_unit_graph old_unit_env)            (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units @@ -832,12 +851,13 @@             , homeUnitEnv_home_unit = Just home_unit             } -        let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph+        let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph         let unit_env = UnitEnv               { ue_platform        = targetPlatform dflags1               , ue_namever         = ghcNameVersion dflags1               , ue_home_unit_graph = home_unit_graph               , ue_current_unit    = ue_currentUnit old_unit_env+              , ue_module_graph    = ue_module_graph old_unit_env               , ue_eps             = ue_eps old_unit_env               }         modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }@@ -846,7 +866,115 @@   when invalidate_needed $ invalidateModSummaryCache   return changed +-- | Sets the program 'HomeUnitGraph'.+--+-- Sets the given 'HomeUnitGraph' as the 'HomeUnitGraph' of the current+-- session. If the package flags change, we reinitialise the 'UnitState'+-- of all 'HomeUnitEnv's in the current session.+--+-- This function unconditionally invalidates the module graph cache.+--+-- Precondition: the given 'HomeUnitGraph' must have the same keys as the 'HomeUnitGraph'+-- of the current session. I.e., assuming the new 'HomeUnitGraph' is called+-- 'new_hug', then:+--+-- @+--  do+--    hug <- hsc_HUG \<$\> getSession+--    pure $ unitEnv_keys new_hug == unitEnv_keys hug+-- @+--+-- If this precondition is violated, the function will crash.+--+-- Conceptually, similar to 'setProgramDynFlags', but performs the same check+-- for all 'HomeUnitEnv's.+setProgramHUG :: GhcMonad m => HomeUnitGraph -> m Bool+setProgramHUG =+  setProgramHUG_ True +-- | Same as 'setProgramHUG', but gives you control over whether you want to+-- invalidate the module graph cache.+setProgramHUG_ :: GhcMonad m => Bool -> HomeUnitGraph -> m Bool+setProgramHUG_ invalidate_needed new_hug0 = do+  logger <- getLogger++  hug0 <- hsc_HUG <$> getSession+  (changed, new_hug1) <- checkNewHugDynFlags logger hug0 new_hug0++  if changed+    then do+      unit_env0 <- hsc_unit_env <$> getSession+      home_unit_graph <- HUG.unitEnv_traverseWithKey+        (updateHomeUnit logger unit_env0 new_hug1)+        (ue_home_unit_graph unit_env0)++      let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit unit_env0) home_unit_graph+      let unit_env = UnitEnv+            { ue_platform        = targetPlatform dflags1+            , ue_namever         = ghcNameVersion dflags1+            , ue_home_unit_graph = home_unit_graph+            , ue_current_unit    = ue_currentUnit unit_env0+            , ue_eps             = ue_eps unit_env0+            , ue_module_graph    = ue_module_graph unit_env0+            }+      modifySession $ \h ->+        -- hscSetFlags takes care of updating the logger as well.+        hscSetFlags dflags1 h{ hsc_unit_env = unit_env }+    else do+      modifySession (\env ->+        env+          -- Set the new 'HomeUnitGraph'.+          & hscUpdateHUG (const new_hug1)+          -- hscSetActiveUnitId makes sure that the 'hsc_dflags'+          -- are up-to-date.+          & hscSetActiveUnitId (hscActiveUnitId env)+          -- Make sure the logger is also updated.+          & hscUpdateLoggerFlags)++  when invalidate_needed $ invalidateModSummaryCache+  pure changed+  where+    checkNewHugDynFlags :: GhcMonad m => Logger -> HomeUnitGraph -> HomeUnitGraph -> m (Bool, HomeUnitGraph)+    checkNewHugDynFlags logger old_hug new_hug = do+      -- Traverse the new HUG and check its 'DynFlags'.+      -- The old 'HUG' is used to check whether package flags have changed.+      hugWithCheck <- HUG.unitEnv_traverseWithKey+        (\unitId homeUnit -> do+          let newFlags = homeUnitEnv_dflags homeUnit+              oldFlags = homeUnitEnv_dflags (HUG.unitEnv_lookup unitId old_hug)+          checkedFlags <- checkNewDynFlags logger newFlags+          pure+            ( packageFlagsChanged oldFlags checkedFlags+            , homeUnit { homeUnitEnv_dflags = checkedFlags }+            )+        )+        new_hug+      let+        -- Did any of the package flags change?+        changed = or $ fmap fst hugWithCheck+        hug = fmap snd hugWithCheck+      pure (changed, hug)++    updateHomeUnit :: GhcMonad m => Logger -> UnitEnv -> HomeUnitGraph -> (UnitId -> HomeUnitEnv -> m HomeUnitEnv)+    updateHomeUnit logger unit_env updates = \uid homeUnitEnv -> do+      let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+          dflags = case HUG.unitEnv_lookup_maybe uid updates of+            Nothing -> homeUnitEnv_dflags homeUnitEnv+            Just env -> homeUnitEnv_dflags env+          old_hpt = homeUnitEnv_hpt homeUnitEnv+          home_units = HUG.allUnits (ue_home_unit_graph unit_env)++      (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units++      updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants+      pure HomeUnitEnv+        { homeUnitEnv_units = unit_state+        , homeUnitEnv_unit_dbs = Just dbs+        , homeUnitEnv_dflags = updated_dflags+        , homeUnitEnv_hpt = old_hpt+        , homeUnitEnv_home_unit = Just home_unit+        }+ -- When changing the DynFlags, we want the changes to apply to future -- loads, but without completely discarding the program.  But the -- DynFlags are cached in each ModSummary in the hsc_mod_graph, so@@ -868,7 +996,7 @@ -- invalidateModSummaryCache :: GhcMonad m => m () invalidateModSummaryCache =-  modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }+  modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env  where   inval ms = ms { ms_hs_hash = fingerprint0 } @@ -885,24 +1013,8 @@ setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do   logger <- getLogger-  dflags' <- checkNewDynFlags logger dflags-  dflags'' <- checkNewInteractiveDynFlags logger dflags'-  modifySessionM $ \hsc_env0 -> do-    let ic0 = hsc_IC hsc_env0--    -- Initialise (load) plugins in the interactive environment with the new-    -- DynFlags-    plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $-                    hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}--    -- Update both plugins cache and DynFlags in the interactive context.-    return $ hsc_env0-                { hsc_IC = ic0-                    { ic_plugins = hsc_plugins plugin_env-                    , ic_dflags  = hsc_dflags  plugin_env-                    }-                }-+  icdflags <- normaliseInteractiveDynFlags logger dflags+  modifySessionM (initialiseInteractiveDynFlags icdflags)  -- | Get the 'DynFlags' used to evaluate interactive expressions. getInteractiveDynFlags :: GhcMonad m => m DynFlags@@ -916,7 +1028,7 @@     -> [Located String]     -> m (DynFlags, [Located String], Messages DriverMessage) parseDynamicFlags logger dflags cmdline = do-  (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline+  (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine logger dflags cmdline   -- flags that have just been read are used by the logger when loading package   -- env (this is checked by T16318)   let logger1 = setLogFlags logger (initLogFlags dflags1)@@ -1007,17 +1119,49 @@  ----------------------------------------------------------------------------- +-- | Normalise the 'DynFlags' for us in an interactive context.+--+-- Makes sure unsupported Flags and other incosistencies are reported and removed.+normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags+normaliseInteractiveDynFlags logger dflags = do+  dflags' <- checkNewDynFlags logger dflags+  checkNewInteractiveDynFlags logger dflags'++-- | Given a set of normalised 'DynFlags' (see 'normaliseInteractiveDynFlags')+-- for the interactive context, initialize the 'InteractiveContext'.+--+-- Initialized plugins and sets the 'DynFlags' as the 'ic_dflags' of the+-- 'InteractiveContext'.+initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv+initialiseInteractiveDynFlags dflags hsc_env0 = do+  let ic0 = hsc_IC hsc_env0++  -- Initialise (load) plugins in the interactive environment with the new+  -- DynFlags+  plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $+                  hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags }}++  -- Update both plugins cache and DynFlags in the interactive context.+  return $ hsc_env0+              { hsc_IC = ic0+                  { ic_plugins = hsc_plugins plugin_env+                  , ic_dflags  = hsc_dflags  plugin_env+                  }+              }+ -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible). checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags checkNewDynFlags logger dflags = do   -- See Note [DynFlags consistency]-  let (dflags', warnings) = makeDynFlagsConsistent dflags+  let (dflags', warnings, infoverb) = makeDynFlagsConsistent dflags   let diag_opts = initDiagOpts dflags       print_config = initPrintConfig dflags   liftIO $ printOrThrowDiagnostics logger print_config diag_opts     $ fmap GhcDriverMessage $ warnsToMessages diag_opts warnings+  when (logVerbAtLeast logger 3) $+    mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb   return dflags'  checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags@@ -1067,7 +1211,7 @@   where    filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ] --- | Attempts to guess what Target a string refers to.  This function+-- | Attempts to guess what 'Target' a string refers to.  This function -- implements the @--make@/GHCi command-line syntax for filenames: -- --   - if the string looks like a Haskell source filename, then interpret it@@ -1076,27 +1220,52 @@ --   - if adding a .hs or .lhs suffix yields the name of an existing file, --     then use that -----   - otherwise interpret the string as a module name+--   - If it looks like a module name, interpret it as such --+--   - otherwise, this function throws a 'GhcException'. guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target guessTarget str mUnitId (Just phase)    = do      tuid <- unitIdOrHomeUnit mUnitId      return (Target (TargetFile str (Just phase)) True tuid Nothing)-guessTarget str mUnitId Nothing+guessTarget str mUnitId Nothing = do+  targetId <- guessTargetId str+  toTarget targetId+     where+         obj_allowed+                | '*':_ <- str = False+                | otherwise    = True+         toTarget tid = do+           tuid <- unitIdOrHomeUnit mUnitId+           pure $ Target tid obj_allowed tuid Nothing++-- | Attempts to guess what 'TargetId' a string refers to.  This function+-- implements the @--make@/GHCi command-line syntax for filenames:+--+--   - if the string looks like a Haskell source filename, then interpret it+--     as such+--+--   - if adding a .hs or .lhs suffix yields the name of an existing file,+--     then use that+--+--   - If it looks like a module name, interpret it as such+--+--   - otherwise, this function throws a 'GhcException'.+guessTargetId :: GhcMonad m => String -> m TargetId+guessTargetId str    | isHaskellSrcFilename file-   = target (TargetFile file Nothing)+   = pure (TargetFile file Nothing)    | otherwise    = do exists <- liftIO $ doesFileExist hs_file         if exists-           then target (TargetFile hs_file Nothing)+           then pure (TargetFile hs_file Nothing)            else do         exists <- liftIO $ doesFileExist lhs_file         if exists-           then target (TargetFile lhs_file Nothing)+           then pure (TargetFile lhs_file Nothing)            else do         if looksLikeModuleName file-           then target (TargetModule (mkModuleName file))+           then pure (TargetModule (mkModuleName file))            else do         dflags <- getDynFlags         liftIO $ throwGhcExceptionIO@@ -1104,16 +1273,12 @@                  text "target" <+> quotes (text file) <+>                  text "is not a module name or a source file"))      where-         (file,obj_allowed)-                | '*':rest <- str = (rest, False)-                | otherwise       = (str,  True)--         hs_file  = file <.> "hs"-         lhs_file = file <.> "lhs"+        file+          | '*':rest <- str = rest+          | otherwise       = str -         target tid = do-           tuid <- unitIdOrHomeUnit mUnitId-           pure $ Target tid obj_allowed tuid Nothing+        hs_file  = file <.> "hs"+        lhs_file = file <.> "lhs"  -- | Unwrap 'UnitId' or retrieve the 'UnitId' -- of the current 'HomeUnit'.@@ -1234,11 +1399,11 @@ -- -- This function ignores boot modules and requires that there is only one -- non-boot module with the given name.-getModSummary :: GhcMonad m => ModuleName -> m ModSummary+getModSummary :: GhcMonad m => Module -> m ModSummary getModSummary mod = do    mg <- liftM hsc_mod_graph getSession    let mods_by_name = [ ms | ms <- mgModSummaries mg-                      , ms_mod_name ms == mod+                      , ms_mod ms == mod                       , isBootSummary ms == NotBoot ]    case mods_by_name of      [] -> do dflags <- getDynFlags@@ -1269,7 +1434,9 @@  liftIO $ do    let ms          = modSummary pmod    let lcl_dflags  = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.)-   let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env+   let lcl_hsc_env =+          hscSetFlags lcl_dflags $+          hscSetActiveUnitId (toUnitId $ moduleUnit $ ms_mod ms) hsc_env    let lcl_logger  = hsc_logger lcl_hsc_env    (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $                         HsParsedModule { hpm_module = parsedSource pmod,@@ -1290,7 +1457,7 @@            minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details,            minf_iface     = Nothing,            minf_safe      = safe,-           minf_modBreaks = emptyModBreaks+           minf_modBreaks = Nothing          }}  -- | Desugar a typechecked module.@@ -1401,155 +1568,6 @@           cm_safe    = safe_mode          } --- %************************************************************************--- %*                                                                      *---             Inspecting the session--- %*                                                                      *--- %************************************************************************---- | Get the module dependency graph.-getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary-getModuleGraph = liftM hsc_mod_graph getSession---- | Return @True@ \<==> module is loaded.-isLoaded :: GhcMonad m => ModuleName -> m Bool-isLoaded m = withSession $ \hsc_env ->-  return $! isJust (lookupHpt (hsc_HPT hsc_env) m)--isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool-isLoadedModule uid m = withSession $ \hsc_env ->-  return $! isJust (lookupHug (hsc_HUG hsc_env) uid m)---- | Return the bindings for the current interactive session.-getBindings :: GhcMonad m => m [TyThing]-getBindings = withSession $ \hsc_env ->-    return $ icInScopeTTs $ hsc_IC hsc_env---- | Return the instances for the current interactive session.-getInsts :: GhcMonad m => m ([ClsInst], [FamInst])-getInsts = withSession $ \hsc_env ->-    let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)-    in return (instEnvElts inst_env, fam_env)--getNamePprCtx :: GhcMonad m => m NamePprCtx-getNamePprCtx = withSession $ \hsc_env -> do-  return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)---- | Container for information about a 'Module'.-data ModuleInfo = ModuleInfo {-        minf_type_env  :: TypeEnv,-        minf_exports   :: [AvailInfo],-        minf_instances :: [ClsInst],-        minf_iface     :: Maybe ModIface,-        minf_safe      :: SafeHaskellMode,-        minf_modBreaks :: ModBreaks-  }-        -- We don't want HomeModInfo here, because a ModuleInfo applies-        -- to package modules too.----- | Request information about a loaded 'Module'-getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X-getModuleInfo mdl = withSession $ \hsc_env -> do-  if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env-        then liftIO $ getHomeModuleInfo hsc_env mdl-        else liftIO $ getPackageModuleInfo hsc_env mdl--getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)-getPackageModuleInfo hsc_env mdl-  = do  eps <- hscEPS hsc_env-        iface <- hscGetModuleInterface hsc_env mdl-        let-            avails = mi_exports iface-            pte    = eps_PTE eps-            tys    = [ ty | name <- concatMap availNames avails,-                            Just ty <- [lookupTypeEnv pte name] ]--        return (Just (ModuleInfo {-                        minf_type_env  = mkTypeEnv tys,-                        minf_exports   = avails,-                        minf_instances = error "getModuleInfo: instances for package module unimplemented",-                        minf_iface     = Just iface,-                        minf_safe      = getSafeMode $ mi_trust iface,-                        minf_modBreaks = emptyModBreaks-                }))--availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv-availsToGlobalRdrEnv hsc_env mod avails-  = forceGlobalRdrEnv rdr_env-    -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.-  where-    rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails)-      -- We're building a GlobalRdrEnv as if the user imported-      -- all the specified modules into the global interactive module-    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}-    decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod,-                         is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual,-                         is_dloc = srcLocSpan interactiveSrcLoc }--getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)-getHomeModuleInfo hsc_env mdl =-  case lookupHugByModule mdl (hsc_HUG hsc_env) of-    Nothing  -> return Nothing-    Just hmi -> do-      let details  = hm_details hmi-          iface    = hm_iface hmi-      return (Just (ModuleInfo {-                        minf_type_env  = md_types details,-                        minf_exports   = md_exports details,-                         -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo.-                        minf_instances = instEnvElts $ md_insts details,-                        minf_iface     = Just iface,-                        minf_safe      = getSafeMode $ mi_trust iface-                       ,minf_modBreaks = getModBreaks hmi-                        }))---- | The list of top-level entities defined in a module-modInfoTyThings :: ModuleInfo -> [TyThing]-modInfoTyThings minf = typeEnvElts (minf_type_env minf)--modInfoExports :: ModuleInfo -> [Name]-modInfoExports minf = concatMap availNames $! minf_exports minf--modInfoExportsWithSelectors :: ModuleInfo -> [Name]-modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf---- | Returns the instances defined by the specified module.--- Warning: currently unimplemented for package modules.-modInfoInstances :: ModuleInfo -> [ClsInst]-modInfoInstances = minf_instances--modInfoIsExportedName :: ModuleInfo -> Name -> Bool-modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))--mkNamePprCtxForModule ::-  GhcMonad m =>-  Module     ->-  ModuleInfo ->-  m NamePprCtx-mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do-  let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))-      ptc = initPromotionTickContext (hsc_dflags hsc_env)-  return name_ppr_ctx--modInfoLookupName :: GhcMonad m =>-                     ModuleInfo -> Name-                  -> m (Maybe TyThing) -- XXX: returns a Maybe X-modInfoLookupName minf name = withSession $ \hsc_env -> do-   case lookupTypeEnv (minf_type_env minf) name of-     Just tyThing -> return (Just tyThing)-     Nothing      -> liftIO (lookupType hsc_env name)--modInfoIface :: ModuleInfo -> Maybe ModIface-modInfoIface = minf_iface---- | Retrieve module safe haskell mode-modInfoSafe :: ModuleInfo -> SafeHaskellMode-modInfoSafe = minf_safe--modInfoModBreaks :: ModuleInfo -> ModBreaks-modInfoModBreaks = minf_modBreaks- isDictonaryId :: Id -> Bool isDictonaryId id = isDictTy (idType id) @@ -1763,7 +1781,7 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $    text "module is not loaded:" <+>    quotes (ppr (moduleName m)) <+>-   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))+   parens (text (expectJust (ml_hs_file loc)))  renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)@@ -1800,12 +1818,56 @@ lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name  lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)-lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> do-  liftIO $ trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModule" <+> ppr mod_name <+> ppr uid)-  case lookupHug  (hsc_HUG hsc_env) uid mod_name  of+lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do+  trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModule" <+> ppr mod_name <+> ppr uid)+  HUG.lookupHug (hsc_HUG hsc_env) uid mod_name >>= \case     Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))     _not_a_home_module -> return Nothing +-- | Lookup the given 'ModuleName' in the 'HomeUnitGraph'.+--+-- Returns 'Nothing' if no 'Module' has the given 'ModuleName'.+-- Otherwise, returns all 'Module's that have the given 'ModuleName'.+--+-- A 'ModuleName' is generally not enough to uniquely identify a 'Module', since+-- there can be multiple units exposing the same 'ModuleName' in the case of+-- multiple home units.+-- Thus, this function may return more than one possible 'Module'.+-- We leave it up to the caller to decide how to handle the ambiguity.+-- For example, GHCi may prompt the user to clarify which 'Module' is the correct one.+--+lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module])+lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do+  trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name)+  HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case+    []        -> return Nothing+    mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos))++-- | Given a 'ModuleName' and 'PkgQual', lookup all 'Module's that may fit the criteria.+--+-- Identically to 'lookupLoadedHomeModuleByModuleName', there may be more than one+-- 'Module' in the 'HomeUnitGraph' that has the given 'ModuleName'.+--+-- The result is guaranteed to be non-empty, if no 'Module' can be found,+-- this function throws an error.+lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module]+lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do+  home <- lookupLoadedHomeModuleByModuleName mod_name+  case home of+    Just m  -> return m+    Nothing -> liftIO $ do+      let fc     = hsc_FC hsc_env+      let units  = hsc_units hsc_env+      let dflags = hsc_dflags hsc_env+      let fopts  = initFinderOpts dflags+      res <- findExposedPackageModule fc fopts units mod_name NoPkgQual+      case res of+        Found _ m -> return [m]+        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err+lookupAllQualifiedModuleNames pkgqual mod_name = do+  m <- findQualifiedModule pkgqual mod_name+  pure [m]+ -- | Check that a module is safe to import (according to Safe Haskell). -- -- We return True to indicate the import is safe and False otherwise@@ -1836,14 +1898,17 @@ getGHCiMonad = fmap (ic_monad . hsc_IC) getSession  getHistorySpan :: GhcMonad m => History -> m SrcSpan-getHistorySpan h = withSession $ \hsc_env ->-    return $ GHC.Runtime.Eval.getHistorySpan hsc_env h+getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan (hsc_HUG hsc_env) h  obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term obtainTermFromVal bound force ty a = withSession $ \hsc_env ->     liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a -obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term+obtainTermFromId :: GhcMonad m+                 => Int -- ^ How many times to recurse for subterms+                 -> Bool -- ^ Whether to force the expression+                 -> Id+                 -> m Term obtainTermFromId bound force id = withSession $ \hsc_env ->     liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id
− compiler/GHC/Builtin/Names/TH.hs 
@@ -1,1202 +0,0 @@--- %************************************************************************--- %*                                                                   *---              The known-key names for Template Haskell--- %*                                                                   *--- %************************************************************************--module GHC.Builtin.Names.TH where--import GHC.Prelude ()--import GHC.Builtin.Names( mk_known_key_name )-import GHC.Unit.Types-import GHC.Types.Name( Name )-import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName, fieldName )-import GHC.Types.Name.Reader( RdrName, nameRdrName )-import GHC.Types.Unique ( Unique )-import GHC.Builtin.Uniques-import GHC.Data.FastString--import Language.Haskell.Syntax.Module.Name---- To add a name, do three things------  1) Allocate a key---  2) Make a "Name"---  3) Add the name to templateHaskellNames--templateHaskellNames :: [Name]--- The names that are implicitly mentioned by ``bracket''--- Should stay in sync with the import list of GHC.HsToCore.Quote--templateHaskellNames = [-    returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,-    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName,-    mkNameLName,-    mkNameSName, mkNameQName,-    mkModNameName,-    liftStringName,-    unTypeName, unTypeCodeName,-    unsafeCodeCoerceName,--    -- Lit-    charLName, stringLName, integerLName, intPrimLName, wordPrimLName,-    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,-    charPrimLName,-    -- Pat-    litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,-    conPName, tildePName, bangPName, infixPName,-    asPName, wildPName, recPName, listPName, sigPName, viewPName,-    typePName, invisPName, orPName,-    -- FieldPat-    fieldPatName,-    -- Match-    matchName,-    -- Clause-    clauseName,-    -- Exp-    varEName, conEName, litEName, appEName, appTypeEName, infixEName,-    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,-    lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName,-    condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,-    fromEName, fromThenEName, fromToEName, fromThenToEName,-    listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,-    labelEName, implicitParamVarEName, getFieldEName, projectionEName,-    typeEName, forallEName, forallVisEName, constrainedEName,-    -- FieldExp-    fieldExpName,-    -- Body-    guardedBName, normalBName,-    -- Guard-    normalGEName, patGEName,-    -- Stmt-    bindSName, letSName, noBindSName, parSName, recSName,-    -- Dec-    funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,-    classDName, instanceWithOverlapDName,-    standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,-    pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,-    pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,-    defaultSigDName, defaultDName,-    dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,-    dataInstDName, newtypeInstDName, tySynInstDName,-    infixLWithSpecDName, infixRWithSpecDName, infixNWithSpecDName,-    roleAnnotDName, patSynDName, patSynSigDName,-    implicitParamBindDName,-    -- Cxt-    cxtName,--    -- SourceUnpackedness-    noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,-    -- SourceStrictness-    noSourceStrictnessName, sourceLazyName, sourceStrictName,-    -- Con-    normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,-    -- Bang-    bangName,-    -- BangType-    bangTypeName,-    -- VarBangType-    varBangTypeName,-    -- PatSynDir (for pattern synonyms)-    unidirPatSynName, implBidirPatSynName, explBidirPatSynName,-    -- PatSynArgs (for pattern synonyms)-    prefixPatSynName, infixPatSynName, recordPatSynName,-    -- Type-    forallTName, forallVisTName, varTName, conTName, infixTName, appTName,-    appKindTName, equalityTName, tupleTName, unboxedTupleTName,-    unboxedSumTName, arrowTName, mulArrowTName, listTName, sigTName, litTName,-    promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,-    wildCardTName, implicitParamTName,-    -- TyLit-    numTyLitName, strTyLitName, charTyLitName,-    -- TyVarBndr-    plainTVName, kindedTVName,-    plainInvisTVName, kindedInvisTVName,-    plainBndrTVName, kindedBndrTVName,-    -- Specificity-    specifiedSpecName, inferredSpecName,-    -- Visibility-    bndrReqName, bndrInvisName,-    -- Role-    nominalRName, representationalRName, phantomRName, inferRName,-    -- Kind-    starKName, constraintKName,-    -- FamilyResultSig-    noSigName, kindSigName, tyVarSigName,-    -- InjectivityAnn-    injectivityAnnName,-    -- Callconv-    cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,-    -- Safety-    unsafeName,-    safeName,-    interruptibleName,-    -- Inline-    noInlineDataConName, inlineDataConName, inlinableDataConName,-    -- RuleMatch-    conLikeDataConName, funLikeDataConName,-    -- Phases-    allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,-    -- Overlap-    overlappableDataConName, overlappingDataConName, overlapsDataConName,-    incoherentDataConName,-    -- NamespaceSpecifier-    noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName,-    dataNamespaceSpecifierDataConName,-    -- DerivStrategy-    stockStrategyName, anyclassStrategyName,-    newtypeStrategyName, viaStrategyName,-    -- RuleBndr-    ruleVarName, typedRuleVarName,-    -- FunDep-    funDepName,-    -- TySynEqn-    tySynEqnName,-    -- AnnTarget-    valueAnnotationName, typeAnnotationName, moduleAnnotationName,-    -- DerivClause-    derivClauseName,--    -- The type classes-    liftClassName, quoteClassName,--    -- And the tycons-    qTyConName, nameTyConName, patTyConName,-    fieldPatTyConName, matchTyConName,-    expQTyConName, fieldExpTyConName, predTyConName,-    stmtTyConName,  decsTyConName, conTyConName, bangTypeTyConName,-    varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,-    typeTyConName,-    tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName,-    clauseTyConName,-    patQTyConName, funDepTyConName, decsQTyConName,-    ruleBndrTyConName, tySynEqnTyConName,-    roleTyConName, codeTyConName, injAnnTyConName, kindTyConName,-    overlapTyConName, derivClauseTyConName, derivStrategyTyConName,-    modNameTyConName,--    -- Quasiquoting-    quoteDecName, quoteTypeName, quoteExpName, quotePatName]--thSyn, thLib, qqLib, liftLib :: Module-thSyn = mkTHModule (fsLit "GHC.Internal.TH.Syntax")-thLib = mkTHModule (fsLit "GHC.Internal.TH.Lib")-qqLib = mkTHModule (fsLit "GHC.Internal.TH.Quote")-liftLib = mkTHModule (fsLit "GHC.Internal.TH.Lift")--mkTHModule :: FastString -> Module-mkTHModule m = mkModule ghcInternalUnit (mkModuleNameFS m)--libFun, libTc, thFun, thTc, thCls, thCon, liftFun :: FastString -> Unique -> Name-libFun = mk_known_key_name varName  thLib-libTc  = mk_known_key_name tcName   thLib-thFun  = mk_known_key_name varName  thSyn-thTc   = mk_known_key_name tcName   thSyn-thCls  = mk_known_key_name clsName  thSyn-thCon  = mk_known_key_name dataName thSyn-liftFun = mk_known_key_name varName liftLib--thFld :: FastString -> FastString -> Unique -> Name-thFld con = mk_known_key_name (fieldName con) thSyn--qqFld :: FastString -> Unique -> Name-qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib---------------------- TH.Syntax ------------------------liftClassName :: Name-liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey--quoteClassName :: Name-quoteClassName = thCls (fsLit "Quote") quoteClassKey--qTyConName, nameTyConName, fieldExpTyConName, patTyConName,-    fieldPatTyConName, expTyConName, decTyConName, typeTyConName,-    matchTyConName, clauseTyConName, funDepTyConName, predTyConName,-    codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName,-    modNameTyConName :: Name-qTyConName             = thTc (fsLit "Q")              qTyConKey-nameTyConName          = thTc (fsLit "Name")           nameTyConKey-fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey-patTyConName           = thTc (fsLit "Pat")            patTyConKey-fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey-expTyConName           = thTc (fsLit "Exp")            expTyConKey-decTyConName           = thTc (fsLit "Dec")            decTyConKey-decsTyConName          = libTc (fsLit "Decs")           decsTyConKey-typeTyConName          = thTc (fsLit "Type")           typeTyConKey-matchTyConName         = thTc (fsLit "Match")          matchTyConKey-clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey-funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey-predTyConName          = thTc (fsLit "Pred")           predTyConKey-codeTyConName          = thTc (fsLit "Code")           codeTyConKey-injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey-overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey-modNameTyConName       = thTc (fsLit "ModName")        modNameTyConKey--returnQName, bindQName, sequenceQName, newNameName, liftName,-    mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName,-    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,-    unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name-returnQName    = thFun (fsLit "returnQ")   returnQIdKey-bindQName      = thFun (fsLit "bindQ")     bindQIdKey-sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey-newNameName    = thFun (fsLit "newName")   newNameIdKey-mkNameName     = thFun (fsLit "mkName")     mkNameIdKey-mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey-mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey-mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey-mkNameG_fldName= thFun (fsLit "mkNameG_fld") mkNameG_fldIdKey-mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey-mkNameQName    = thFun (fsLit "mkNameQ")    mkNameQIdKey-mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey-mkModNameName  = thFun (fsLit "mkModName")  mkModNameIdKey-unTypeName     = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey-unTypeCodeName    = thFun (fsLit "unTypeCode") unTypeCodeIdKey-unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey-liftName       = liftFun (fsLit "lift")      liftIdKey-liftStringName = liftFun (fsLit "liftString")  liftStringIdKey-liftTypedName = liftFun (fsLit "liftTyped") liftTypedIdKey----------------------- TH.Lib -------------------------- data Lit = ...-charLName, stringLName, integerLName, intPrimLName, wordPrimLName,-    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,-    charPrimLName :: Name-charLName       = libFun (fsLit "charL")       charLIdKey-stringLName     = libFun (fsLit "stringL")     stringLIdKey-integerLName    = libFun (fsLit "integerL")    integerLIdKey-intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey-wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey-floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey-doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey-rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey-stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey-charPrimLName   = libFun (fsLit "charPrimL")   charPrimLIdKey---- data Pat = ...-litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,-    infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,-    sigPName, viewPName, typePName, invisPName, orPName :: Name-litPName   = libFun (fsLit "litP")   litPIdKey-varPName   = libFun (fsLit "varP")   varPIdKey-tupPName   = libFun (fsLit "tupP")   tupPIdKey-unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey-unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey-conPName   = libFun (fsLit "conP")   conPIdKey-infixPName = libFun (fsLit "infixP") infixPIdKey-tildePName = libFun (fsLit "tildeP") tildePIdKey-bangPName  = libFun (fsLit "bangP")  bangPIdKey-asPName    = libFun (fsLit "asP")    asPIdKey-wildPName  = libFun (fsLit "wildP")  wildPIdKey-recPName   = libFun (fsLit "recP")   recPIdKey-listPName  = libFun (fsLit "listP")  listPIdKey-sigPName   = libFun (fsLit "sigP")   sigPIdKey-viewPName  = libFun (fsLit "viewP")  viewPIdKey-orPName    = libFun (fsLit "orP")    orPIdKey-typePName  = libFun (fsLit "typeP")  typePIdKey-invisPName = libFun (fsLit "invisP") invisPIdKey---- type FieldPat = ...-fieldPatName :: Name-fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey---- data Match = ...-matchName :: Name-matchName = libFun (fsLit "match") matchIdKey---- data Clause = ...-clauseName :: Name-clauseName = libFun (fsLit "clause") clauseIdKey---- data Exp = ...-varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,-    sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,-    unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,-    caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,-    labelEName, implicitParamVarEName, getFieldEName, projectionEName, typeEName,-    forallEName, forallVisEName, constrainedEName :: Name-varEName              = libFun (fsLit "varE")              varEIdKey-conEName              = libFun (fsLit "conE")              conEIdKey-litEName              = libFun (fsLit "litE")              litEIdKey-appEName              = libFun (fsLit "appE")              appEIdKey-appTypeEName          = libFun (fsLit "appTypeE")          appTypeEIdKey-infixEName            = libFun (fsLit "infixE")            infixEIdKey-infixAppName          = libFun (fsLit "infixApp")          infixAppIdKey-sectionLName          = libFun (fsLit "sectionL")          sectionLIdKey-sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey-lamEName              = libFun (fsLit "lamE")              lamEIdKey-lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey-lamCasesEName         = libFun (fsLit "lamCasesE")         lamCasesEIdKey-tupEName              = libFun (fsLit "tupE")              tupEIdKey-unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey-unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey-condEName             = libFun (fsLit "condE")             condEIdKey-multiIfEName          = libFun (fsLit "multiIfE")          multiIfEIdKey-letEName              = libFun (fsLit "letE")              letEIdKey-caseEName             = libFun (fsLit "caseE")             caseEIdKey-doEName               = libFun (fsLit "doE")               doEIdKey-mdoEName              = libFun (fsLit "mdoE")              mdoEIdKey-compEName             = libFun (fsLit "compE")             compEIdKey--- ArithSeq skips a level-fromEName, fromThenEName, fromToEName, fromThenToEName :: Name-fromEName             = libFun (fsLit "fromE")             fromEIdKey-fromThenEName         = libFun (fsLit "fromThenE")         fromThenEIdKey-fromToEName           = libFun (fsLit "fromToE")           fromToEIdKey-fromThenToEName       = libFun (fsLit "fromThenToE")       fromThenToEIdKey--- end ArithSeq-listEName, sigEName, recConEName, recUpdEName :: Name-listEName             = libFun (fsLit "listE")             listEIdKey-sigEName              = libFun (fsLit "sigE")              sigEIdKey-recConEName           = libFun (fsLit "recConE")           recConEIdKey-recUpdEName           = libFun (fsLit "recUpdE")           recUpdEIdKey-staticEName           = libFun (fsLit "staticE")           staticEIdKey-unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey-labelEName            = libFun (fsLit "labelE")            labelEIdKey-implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey-getFieldEName         = libFun (fsLit "getFieldE")         getFieldEIdKey-projectionEName       = libFun (fsLit "projectionE")       projectionEIdKey-typeEName             = libFun (fsLit "typeE")             typeEIdKey-forallEName           = libFun (fsLit "forallE")           forallEIdKey-forallVisEName        = libFun (fsLit "forallVisE")        forallVisEIdKey-constrainedEName      = libFun (fsLit "constrainedE")      constrainedEIdKey---- type FieldExp = ...-fieldExpName :: Name-fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey---- data Body = ...-guardedBName, normalBName :: Name-guardedBName = libFun (fsLit "guardedB") guardedBIdKey-normalBName  = libFun (fsLit "normalB")  normalBIdKey---- data Guard = ...-normalGEName, patGEName :: Name-normalGEName = libFun (fsLit "normalGE") normalGEIdKey-patGEName    = libFun (fsLit "patGE")    patGEIdKey---- data Stmt = ...-bindSName, letSName, noBindSName, parSName, recSName :: Name-bindSName   = libFun (fsLit "bindS")   bindSIdKey-letSName    = libFun (fsLit "letS")    letSIdKey-noBindSName = libFun (fsLit "noBindS") noBindSIdKey-parSName    = libFun (fsLit "parS")    parSIdKey-recSName    = libFun (fsLit "recS")    recSIdKey---- data Dec = ...-funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,-    instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,-    pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,-    pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,-    standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,-    dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,-    openTypeFamilyDName, closedTypeFamilyDName, infixLWithSpecDName,-    infixRWithSpecDName, infixNWithSpecDName, roleAnnotDName, patSynDName,-    patSynSigDName, pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name-funDName                         = libFun (fsLit "funD")                         funDIdKey-valDName                         = libFun (fsLit "valD")                         valDIdKey-dataDName                        = libFun (fsLit "dataD")                        dataDIdKey-newtypeDName                     = libFun (fsLit "newtypeD")                     newtypeDIdKey-typeDataDName                    = libFun (fsLit "typeDataD")                    typeDataDIdKey-tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey-classDName                       = libFun (fsLit "classD")                       classDIdKey-instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey-standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey-sigDName                         = libFun (fsLit "sigD")                         sigDIdKey-kiSigDName                       = libFun (fsLit "kiSigD")                       kiSigDIdKey-defaultDName                     = libFun (fsLit "defaultD")                     defaultDIdKey-defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey-forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey-pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey-pragOpaqueDName                  = libFun (fsLit "pragOpaqueD")                  pragOpaqueDIdKey-pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey-pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey-pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey-pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey-pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey-pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey-pragSCCFunDName                  = libFun (fsLit "pragSCCFunD")                  pragSCCFunDKey-pragSCCFunNamedDName             = libFun (fsLit "pragSCCFunNamedD")             pragSCCFunNamedDKey-dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey-newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey-tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey-openTypeFamilyDName              = libFun (fsLit "openTypeFamilyD")              openTypeFamilyDIdKey-closedTypeFamilyDName            = libFun (fsLit "closedTypeFamilyD")            closedTypeFamilyDIdKey-dataFamilyDName                  = libFun (fsLit "dataFamilyD")                  dataFamilyDIdKey-infixLWithSpecDName              = libFun (fsLit "infixLWithSpecD")              infixLWithSpecDIdKey-infixRWithSpecDName              = libFun (fsLit "infixRWithSpecD")              infixRWithSpecDIdKey-infixNWithSpecDName              = libFun (fsLit "infixNWithSpecD")              infixNWithSpecDIdKey-roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey-patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey-patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey-implicitParamBindDName           = libFun (fsLit "implicitParamBindD")           implicitParamBindDIdKey---- type Ctxt = ...-cxtName :: Name-cxtName = libFun (fsLit "cxt") cxtIdKey---- data SourceUnpackedness = ...-noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name-noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey-sourceNoUnpackName       = libFun (fsLit "sourceNoUnpack")       sourceNoUnpackKey-sourceUnpackName         = libFun (fsLit "sourceUnpack")         sourceUnpackKey---- data SourceStrictness = ...-noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name-noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey-sourceLazyName         = libFun (fsLit "sourceLazy")         sourceLazyKey-sourceStrictName       = libFun (fsLit "sourceStrict")       sourceStrictKey---- data Con = ...-normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name-normalCName  = libFun (fsLit "normalC" ) normalCIdKey-recCName     = libFun (fsLit "recC"    ) recCIdKey-infixCName   = libFun (fsLit "infixC"  ) infixCIdKey-forallCName  = libFun (fsLit "forallC" ) forallCIdKey-gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey-recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey---- data Bang = ...-bangName :: Name-bangName = libFun (fsLit "bang") bangIdKey---- type BangType = ...-bangTypeName :: Name-bangTypeName = libFun (fsLit "bangType") bangTKey---- type VarBangType = ...-varBangTypeName :: Name-varBangTypeName = libFun (fsLit "varBangType") varBangTKey---- data PatSynDir = ...-unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name-unidirPatSynName    = libFun (fsLit "unidir")    unidirPatSynIdKey-implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey-explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey---- data PatSynArgs = ...-prefixPatSynName, infixPatSynName, recordPatSynName :: Name-prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey-infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey-recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey---- data Type = ...-forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName,-    unboxedTupleTName, unboxedSumTName, arrowTName, mulArrowTName, listTName,-    appTName, appKindTName, sigTName, equalityTName, litTName, promotedTName,-    promotedTupleTName, promotedNilTName, promotedConsTName,-    wildCardTName, implicitParamTName :: Name-forallTName         = libFun (fsLit "forallT")        forallTIdKey-forallVisTName      = libFun (fsLit "forallVisT")     forallVisTIdKey-varTName            = libFun (fsLit "varT")           varTIdKey-conTName            = libFun (fsLit "conT")           conTIdKey-tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey-unboxedTupleTName   = libFun (fsLit "unboxedTupleT")  unboxedTupleTIdKey-unboxedSumTName     = libFun (fsLit "unboxedSumT")    unboxedSumTIdKey-arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey-mulArrowTName       = libFun (fsLit "mulArrowT")      mulArrowTIdKey-listTName           = libFun (fsLit "listT")          listTIdKey-appTName            = libFun (fsLit "appT")           appTIdKey-appKindTName        = libFun (fsLit "appKindT")       appKindTIdKey-sigTName            = libFun (fsLit "sigT")           sigTIdKey-equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey-litTName            = libFun (fsLit "litT")           litTIdKey-promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey-promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey-promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey-promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey-wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey-infixTName          = libFun (fsLit "infixT")         infixTIdKey-implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey---- data TyLit = ...-numTyLitName, strTyLitName, charTyLitName :: Name-numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey-strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey-charTyLitName = libFun (fsLit "charTyLit") charTyLitIdKey---- data TyVarBndr = ...-plainTVName, kindedTVName :: Name-plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey-kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey--plainInvisTVName, kindedInvisTVName :: Name-plainInvisTVName  = libFun (fsLit "plainInvisTV")  plainInvisTVIdKey-kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey--plainBndrTVName, kindedBndrTVName :: Name-plainBndrTVName  = libFun (fsLit "plainBndrTV")  plainBndrTVIdKey-kindedBndrTVName = libFun (fsLit "kindedBndrTV") kindedBndrTVIdKey---- data Specificity = ...-specifiedSpecName, inferredSpecName :: Name-specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey-inferredSpecName  = libFun (fsLit "inferredSpec")  inferredSpecKey---- data BndrVis = ...-bndrReqName, bndrInvisName :: Name-bndrReqName   = libFun (fsLit "bndrReq")   bndrReqKey-bndrInvisName = libFun (fsLit "bndrInvis") bndrInvisKey---- data Role = ...-nominalRName, representationalRName, phantomRName, inferRName :: Name-nominalRName          = libFun (fsLit "nominalR")          nominalRIdKey-representationalRName = libFun (fsLit "representationalR") representationalRIdKey-phantomRName          = libFun (fsLit "phantomR")          phantomRIdKey-inferRName            = libFun (fsLit "inferR")            inferRIdKey---- data Kind = ...-starKName, constraintKName :: Name-starKName       = libFun (fsLit "starK")        starKIdKey-constraintKName = libFun (fsLit "constraintK")  constraintKIdKey---- data FamilyResultSig = ...-noSigName, kindSigName, tyVarSigName :: Name-noSigName    = libFun (fsLit "noSig")    noSigIdKey-kindSigName  = libFun (fsLit "kindSig")  kindSigIdKey-tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey---- data InjectivityAnn = ...-injectivityAnnName :: Name-injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey---- data Callconv = ...-cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name-cCallName = libFun (fsLit "cCall") cCallIdKey-stdCallName = libFun (fsLit "stdCall") stdCallIdKey-cApiCallName = libFun (fsLit "cApi") cApiCallIdKey-primCallName = libFun (fsLit "prim") primCallIdKey-javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey---- data Safety = ...-unsafeName, safeName, interruptibleName :: Name-unsafeName     = libFun (fsLit "unsafe") unsafeIdKey-safeName       = libFun (fsLit "safe") safeIdKey-interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey---- data RuleBndr = ...-ruleVarName, typedRuleVarName :: Name-ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey-typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey---- data FunDep = ...-funDepName :: Name-funDepName     = libFun (fsLit "funDep") funDepIdKey---- data TySynEqn = ...-tySynEqnName :: Name-tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey---- data AnnTarget = ...-valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name-valueAnnotationName  = libFun (fsLit "valueAnnotation")  valueAnnotationIdKey-typeAnnotationName   = libFun (fsLit "typeAnnotation")   typeAnnotationIdKey-moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey---- type DerivClause = ...-derivClauseName :: Name-derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey---- data DerivStrategy = ...-stockStrategyName, anyclassStrategyName, newtypeStrategyName,-  viaStrategyName :: Name-stockStrategyName    = libFun (fsLit "stockStrategy")    stockStrategyIdKey-anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey-newtypeStrategyName  = libFun (fsLit "newtypeStrategy")  newtypeStrategyIdKey-viaStrategyName      = libFun (fsLit "viaStrategy")      viaStrategyIdKey--patQTyConName, expQTyConName, stmtTyConName,-    conTyConName, bangTypeTyConName,-    varBangTypeTyConName, typeQTyConName,-    decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName,-    derivClauseTyConName, kindTyConName,-    tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName,-    derivStrategyTyConName :: Name--- These are only used for the types of top-level splices-expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey-decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]-typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey-patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey---- These are used in GHC.HsToCore.Quote but always wrapped in a type variable-stmtTyConName           = thTc (fsLit "Stmt")            stmtTyConKey-conTyConName            = thTc (fsLit "Con")             conTyConKey-bangTypeTyConName       = thTc (fsLit "BangType")      bangTypeTyConKey-varBangTypeTyConName    = thTc (fsLit "VarBangType")     varBangTypeTyConKey-ruleBndrTyConName      = thTc (fsLit "RuleBndr")      ruleBndrTyConKey-tySynEqnTyConName       = thTc  (fsLit "TySynEqn")       tySynEqnTyConKey-roleTyConName           = libTc (fsLit "Role")           roleTyConKey-derivClauseTyConName   = thTc (fsLit "DerivClause")   derivClauseTyConKey-kindTyConName          = thTc (fsLit "Kind")          kindTyConKey-tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey-tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey-tyVarBndrVisTyConName  = libTc (fsLit "TyVarBndrVis")  tyVarBndrVisTyConKey-derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey---- quasiquoting-quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name-quoteExpName  = qqFld (fsLit "quoteExp")  quoteExpKey-quotePatName  = qqFld (fsLit "quotePat")  quotePatKey-quoteDecName  = qqFld (fsLit "quoteDec")  quoteDecKey-quoteTypeName = qqFld (fsLit "quoteType") quoteTypeKey---- data Inline = ...-noInlineDataConName, inlineDataConName, inlinableDataConName :: Name-noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey-inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey-inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey---- data RuleMatch = ...-conLikeDataConName, funLikeDataConName :: Name-conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey-funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey---- data Phases = ...-allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name-allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey-fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey-beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey---- data Overlap = ...-overlappableDataConName,-  overlappingDataConName,-  overlapsDataConName,-  incoherentDataConName :: Name-overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey-overlappingDataConName  = thCon (fsLit "Overlapping")  overlappingDataConKey-overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey-incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey---- data NamespaceSpecifier = ...-noNamespaceSpecifierDataConName,-  typeNamespaceSpecifierDataConName,-  dataNamespaceSpecifierDataConName :: Name-noNamespaceSpecifierDataConName =-  thCon (fsLit "NoNamespaceSpecifier") noNamespaceSpecifierDataConKey-typeNamespaceSpecifierDataConName =-  thCon (fsLit "TypeNamespaceSpecifier") typeNamespaceSpecifierDataConKey-dataNamespaceSpecifierDataConName =-  thCon (fsLit "DataNamespaceSpecifier") dataNamespaceSpecifierDataConKey--{- *********************************************************************-*                                                                      *-                     Class keys-*                                                                      *-********************************************************************* -}---- ClassUniques available: 200-299--- Check in GHC.Builtin.Names if you want to change this--liftClassKey :: Unique-liftClassKey = mkPreludeClassUnique 200--quoteClassKey :: Unique-quoteClassKey = mkPreludeClassUnique 201--{- *********************************************************************-*                                                                      *-                     TyCon keys-*                                                                      *-********************************************************************* -}---- TyConUniques available: 200-299--- Check in GHC.Builtin.Names if you want to change this--expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,-    patTyConKey,-    stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey,-    tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, tyVarBndrVisTyConKey,-    decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,-    fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,-    funDepTyConKey, predTyConKey,-    predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,-    roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey,-    overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey,-    modNameTyConKey  :: Unique-expTyConKey             = mkPreludeTyConUnique 200-matchTyConKey           = mkPreludeTyConUnique 201-clauseTyConKey          = mkPreludeTyConUnique 202-qTyConKey               = mkPreludeTyConUnique 203-expQTyConKey            = mkPreludeTyConUnique 204-patTyConKey             = mkPreludeTyConUnique 206-stmtTyConKey            = mkPreludeTyConUnique 209-conTyConKey             = mkPreludeTyConUnique 210-typeQTyConKey           = mkPreludeTyConUnique 211-typeTyConKey            = mkPreludeTyConUnique 212-decTyConKey             = mkPreludeTyConUnique 213-bangTypeTyConKey        = mkPreludeTyConUnique 214-varBangTypeTyConKey     = mkPreludeTyConUnique 215-fieldExpTyConKey        = mkPreludeTyConUnique 216-fieldPatTyConKey        = mkPreludeTyConUnique 217-nameTyConKey            = mkPreludeTyConUnique 218-patQTyConKey            = mkPreludeTyConUnique 219-funDepTyConKey          = mkPreludeTyConUnique 222-predTyConKey            = mkPreludeTyConUnique 223-predQTyConKey           = mkPreludeTyConUnique 224-tyVarBndrUnitTyConKey   = mkPreludeTyConUnique 225-decsQTyConKey           = mkPreludeTyConUnique 226-ruleBndrTyConKey        = mkPreludeTyConUnique 227-tySynEqnTyConKey        = mkPreludeTyConUnique 228-roleTyConKey            = mkPreludeTyConUnique 229-injAnnTyConKey          = mkPreludeTyConUnique 231-kindTyConKey            = mkPreludeTyConUnique 232-overlapTyConKey         = mkPreludeTyConUnique 233-derivClauseTyConKey     = mkPreludeTyConUnique 234-derivStrategyTyConKey   = mkPreludeTyConUnique 235-decsTyConKey            = mkPreludeTyConUnique 236-tyVarBndrSpecTyConKey   = mkPreludeTyConUnique 237-codeTyConKey            = mkPreludeTyConUnique 238-modNameTyConKey         = mkPreludeTyConUnique 239-tyVarBndrVisTyConKey    = mkPreludeTyConUnique 240--{- *********************************************************************-*                                                                      *-                     DataCon keys-*                                                                      *-********************************************************************* -}---- DataConUniques available: 100-150--- If you want to change this, make sure you check in GHC.Builtin.Names---- data Inline = ...-noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique-noInlineDataConKey  = mkPreludeDataConUnique 200-inlineDataConKey    = mkPreludeDataConUnique 201-inlinableDataConKey = mkPreludeDataConUnique 202---- data RuleMatch = ...-conLikeDataConKey, funLikeDataConKey :: Unique-conLikeDataConKey = mkPreludeDataConUnique 204-funLikeDataConKey = mkPreludeDataConUnique 205---- data Phases = ...-allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique-allPhasesDataConKey   = mkPreludeDataConUnique 206-fromPhaseDataConKey   = mkPreludeDataConUnique 207-beforePhaseDataConKey = mkPreludeDataConUnique 208---- data Overlap = ..-overlappableDataConKey,-  overlappingDataConKey,-  overlapsDataConKey,-  incoherentDataConKey :: Unique-overlappableDataConKey = mkPreludeDataConUnique 209-overlappingDataConKey  = mkPreludeDataConUnique 210-overlapsDataConKey     = mkPreludeDataConUnique 211-incoherentDataConKey   = mkPreludeDataConUnique 212---- data NamespaceSpecifier = ...-noNamespaceSpecifierDataConKey,-  typeNamespaceSpecifierDataConKey,-  dataNamespaceSpecifierDataConKey :: Unique-noNamespaceSpecifierDataConKey = mkPreludeDataConUnique 213-typeNamespaceSpecifierDataConKey = mkPreludeDataConUnique 214-dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215-{- *********************************************************************-*                                                                      *-                     Id keys-*                                                                      *-********************************************************************* -}---- IdUniques available: 200-499--- If you want to change this, make sure you check in GHC.Builtin.Names--returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,-    mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,-    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,-    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique-returnQIdKey        = mkPreludeMiscIdUnique 200-bindQIdKey          = mkPreludeMiscIdUnique 201-sequenceQIdKey      = mkPreludeMiscIdUnique 202-liftIdKey           = mkPreludeMiscIdUnique 203-newNameIdKey         = mkPreludeMiscIdUnique 204-mkNameIdKey          = mkPreludeMiscIdUnique 205-mkNameG_vIdKey       = mkPreludeMiscIdUnique 206-mkNameG_dIdKey       = mkPreludeMiscIdUnique 207-mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208-mkNameLIdKey         = mkPreludeMiscIdUnique 209-mkNameSIdKey         = mkPreludeMiscIdUnique 210-unTypeIdKey          = mkPreludeMiscIdUnique 211-unTypeCodeIdKey      = mkPreludeMiscIdUnique 212-liftTypedIdKey        = mkPreludeMiscIdUnique 214-mkModNameIdKey        = mkPreludeMiscIdUnique 215-unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216-mkNameQIdKey         = mkPreludeMiscIdUnique 217-mkNameG_fldIdKey     = mkPreludeMiscIdUnique 218----- data Lit = ...-charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,-    floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey,-    charPrimLIdKey:: Unique-charLIdKey        = mkPreludeMiscIdUnique 220-stringLIdKey      = mkPreludeMiscIdUnique 221-integerLIdKey     = mkPreludeMiscIdUnique 222-intPrimLIdKey     = mkPreludeMiscIdUnique 223-wordPrimLIdKey    = mkPreludeMiscIdUnique 224-floatPrimLIdKey   = mkPreludeMiscIdUnique 225-doublePrimLIdKey  = mkPreludeMiscIdUnique 226-rationalLIdKey    = mkPreludeMiscIdUnique 227-stringPrimLIdKey  = mkPreludeMiscIdUnique 228-charPrimLIdKey    = mkPreludeMiscIdUnique 229--liftStringIdKey :: Unique-liftStringIdKey     = mkPreludeMiscIdUnique 230---- data Pat = ...-litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,-  infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,-  listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey, orPIdKey :: Unique-litPIdKey         = mkPreludeMiscIdUnique 240-varPIdKey         = mkPreludeMiscIdUnique 241-tupPIdKey         = mkPreludeMiscIdUnique 242-unboxedTupPIdKey  = mkPreludeMiscIdUnique 243-unboxedSumPIdKey  = mkPreludeMiscIdUnique 244-conPIdKey         = mkPreludeMiscIdUnique 245-infixPIdKey       = mkPreludeMiscIdUnique 246-tildePIdKey       = mkPreludeMiscIdUnique 247-bangPIdKey        = mkPreludeMiscIdUnique 248-asPIdKey          = mkPreludeMiscIdUnique 249-wildPIdKey        = mkPreludeMiscIdUnique 250-recPIdKey         = mkPreludeMiscIdUnique 251-listPIdKey        = mkPreludeMiscIdUnique 252-sigPIdKey         = mkPreludeMiscIdUnique 253-viewPIdKey        = mkPreludeMiscIdUnique 254-typePIdKey        = mkPreludeMiscIdUnique 255-invisPIdKey       = mkPreludeMiscIdUnique 256-orPIdKey          = mkPreludeMiscIdUnique 257---- type FieldPat = ...-fieldPatIdKey :: Unique-fieldPatIdKey       = mkPreludeMiscIdUnique 260---- data Match = ...-matchIdKey :: Unique-matchIdKey          = mkPreludeMiscIdUnique 261---- data Clause = ...-clauseIdKey :: Unique-clauseIdKey         = mkPreludeMiscIdUnique 262----- data Exp = ...-varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,-    infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,-    lamCasesEIdKey, tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey,-    multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey,-    fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,-    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,-    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,-    getFieldEIdKey, projectionEIdKey, typeEIdKey, forallEIdKey,-    forallVisEIdKey, constrainedEIdKey :: Unique-varEIdKey              = mkPreludeMiscIdUnique 270-conEIdKey              = mkPreludeMiscIdUnique 271-litEIdKey              = mkPreludeMiscIdUnique 272-appEIdKey              = mkPreludeMiscIdUnique 273-appTypeEIdKey          = mkPreludeMiscIdUnique 274-infixEIdKey            = mkPreludeMiscIdUnique 275-infixAppIdKey          = mkPreludeMiscIdUnique 276-sectionLIdKey          = mkPreludeMiscIdUnique 277-sectionRIdKey          = mkPreludeMiscIdUnique 278-lamEIdKey              = mkPreludeMiscIdUnique 279-lamCaseEIdKey          = mkPreludeMiscIdUnique 280-lamCasesEIdKey         = mkPreludeMiscIdUnique 281-tupEIdKey              = mkPreludeMiscIdUnique 282-unboxedTupEIdKey       = mkPreludeMiscIdUnique 283-unboxedSumEIdKey       = mkPreludeMiscIdUnique 284-condEIdKey             = mkPreludeMiscIdUnique 285-multiIfEIdKey          = mkPreludeMiscIdUnique 286-letEIdKey              = mkPreludeMiscIdUnique 287-caseEIdKey             = mkPreludeMiscIdUnique 288-doEIdKey               = mkPreludeMiscIdUnique 289-compEIdKey             = mkPreludeMiscIdUnique 290-fromEIdKey             = mkPreludeMiscIdUnique 291-fromThenEIdKey         = mkPreludeMiscIdUnique 292-fromToEIdKey           = mkPreludeMiscIdUnique 293-fromThenToEIdKey       = mkPreludeMiscIdUnique 294-listEIdKey             = mkPreludeMiscIdUnique 295-sigEIdKey              = mkPreludeMiscIdUnique 296-recConEIdKey           = mkPreludeMiscIdUnique 297-recUpdEIdKey           = mkPreludeMiscIdUnique 298-staticEIdKey           = mkPreludeMiscIdUnique 299-unboundVarEIdKey       = mkPreludeMiscIdUnique 300-labelEIdKey            = mkPreludeMiscIdUnique 301-implicitParamVarEIdKey = mkPreludeMiscIdUnique 302-mdoEIdKey              = mkPreludeMiscIdUnique 303-getFieldEIdKey         = mkPreludeMiscIdUnique 304-projectionEIdKey       = mkPreludeMiscIdUnique 305-typeEIdKey             = mkPreludeMiscIdUnique 306-forallEIdKey           = mkPreludeMiscIdUnique 802-forallVisEIdKey        = mkPreludeMiscIdUnique 803-constrainedEIdKey      = mkPreludeMiscIdUnique 804---- type FieldExp = ...-fieldExpIdKey :: Unique-fieldExpIdKey       = mkPreludeMiscIdUnique 307---- data Body = ...-guardedBIdKey, normalBIdKey :: Unique-guardedBIdKey     = mkPreludeMiscIdUnique 308-normalBIdKey      = mkPreludeMiscIdUnique 309---- data Guard = ...-normalGEIdKey, patGEIdKey :: Unique-normalGEIdKey     = mkPreludeMiscIdUnique 310-patGEIdKey        = mkPreludeMiscIdUnique 311---- data Stmt = ...-bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique-bindSIdKey       = mkPreludeMiscIdUnique 312-letSIdKey        = mkPreludeMiscIdUnique 313-noBindSIdKey     = mkPreludeMiscIdUnique 314-parSIdKey        = mkPreludeMiscIdUnique 315-recSIdKey        = mkPreludeMiscIdUnique 316---- data Dec = ...-funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,-    instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,-    pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,-    pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,-    openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,-    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,-    infixLWithSpecDIdKey, infixRWithSpecDIdKey, infixNWithSpecDIdKey,-    roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey,-    implicitParamBindDIdKey, kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey,-    typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey :: Unique-funDIdKey                         = mkPreludeMiscIdUnique 320-valDIdKey                         = mkPreludeMiscIdUnique 321-dataDIdKey                        = mkPreludeMiscIdUnique 322-newtypeDIdKey                     = mkPreludeMiscIdUnique 323-tySynDIdKey                       = mkPreludeMiscIdUnique 324-classDIdKey                       = mkPreludeMiscIdUnique 325-instanceWithOverlapDIdKey         = mkPreludeMiscIdUnique 326-instanceDIdKey                    = mkPreludeMiscIdUnique 327-sigDIdKey                         = mkPreludeMiscIdUnique 328-forImpDIdKey                      = mkPreludeMiscIdUnique 329-pragInlDIdKey                     = mkPreludeMiscIdUnique 330-pragSpecDIdKey                    = mkPreludeMiscIdUnique 331-pragSpecInlDIdKey                 = mkPreludeMiscIdUnique 332-pragSpecInstDIdKey                = mkPreludeMiscIdUnique 333-pragRuleDIdKey                    = mkPreludeMiscIdUnique 334-pragAnnDIdKey                     = mkPreludeMiscIdUnique 335-dataFamilyDIdKey                  = mkPreludeMiscIdUnique 336-openTypeFamilyDIdKey              = mkPreludeMiscIdUnique 337-dataInstDIdKey                    = mkPreludeMiscIdUnique 338-newtypeInstDIdKey                 = mkPreludeMiscIdUnique 339-tySynInstDIdKey                   = mkPreludeMiscIdUnique 340-closedTypeFamilyDIdKey            = mkPreludeMiscIdUnique 341-infixLWithSpecDIdKey              = mkPreludeMiscIdUnique 342-infixRWithSpecDIdKey              = mkPreludeMiscIdUnique 343-infixNWithSpecDIdKey              = mkPreludeMiscIdUnique 344-roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345-standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346-defaultSigDIdKey                  = mkPreludeMiscIdUnique 347-patSynDIdKey                      = mkPreludeMiscIdUnique 348-patSynSigDIdKey                   = mkPreludeMiscIdUnique 349-pragCompleteDIdKey                = mkPreludeMiscIdUnique 350-implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351-kiSigDIdKey                       = mkPreludeMiscIdUnique 352-defaultDIdKey                     = mkPreludeMiscIdUnique 353-pragOpaqueDIdKey                  = mkPreludeMiscIdUnique 354-typeDataDIdKey                    = mkPreludeMiscIdUnique 355-pragSCCFunDKey                    = mkPreludeMiscIdUnique 356-pragSCCFunNamedDKey               = mkPreludeMiscIdUnique 357---- type Cxt = ...-cxtIdKey :: Unique-cxtIdKey               = mkPreludeMiscIdUnique 361---- data SourceUnpackedness = ...-noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique-noSourceUnpackednessKey = mkPreludeMiscIdUnique 362-sourceNoUnpackKey       = mkPreludeMiscIdUnique 363-sourceUnpackKey         = mkPreludeMiscIdUnique 364---- data SourceStrictness = ...-noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique-noSourceStrictnessKey   = mkPreludeMiscIdUnique 365-sourceLazyKey           = mkPreludeMiscIdUnique 366-sourceStrictKey         = mkPreludeMiscIdUnique 367---- data Con = ...-normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,-  recGadtCIdKey :: Unique-normalCIdKey      = mkPreludeMiscIdUnique 368-recCIdKey         = mkPreludeMiscIdUnique 369-infixCIdKey       = mkPreludeMiscIdUnique 370-forallCIdKey      = mkPreludeMiscIdUnique 371-gadtCIdKey        = mkPreludeMiscIdUnique 372-recGadtCIdKey     = mkPreludeMiscIdUnique 373---- data Bang = ...-bangIdKey :: Unique-bangIdKey         = mkPreludeMiscIdUnique 374---- type BangType = ...-bangTKey :: Unique-bangTKey          = mkPreludeMiscIdUnique 375---- type VarBangType = ...-varBangTKey :: Unique-varBangTKey       = mkPreludeMiscIdUnique 376---- data PatSynDir = ...-unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique-unidirPatSynIdKey    = mkPreludeMiscIdUnique 377-implBidirPatSynIdKey = mkPreludeMiscIdUnique 378-explBidirPatSynIdKey = mkPreludeMiscIdUnique 379---- data PatSynArgs = ...-prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique-prefixPatSynIdKey = mkPreludeMiscIdUnique 380-infixPatSynIdKey  = mkPreludeMiscIdUnique 381-recordPatSynIdKey = mkPreludeMiscIdUnique 382---- data Type = ...-forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey,-    unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey,-    appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,-    promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,-    wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique-forallTIdKey        = mkPreludeMiscIdUnique 390-forallVisTIdKey     = mkPreludeMiscIdUnique 391-varTIdKey           = mkPreludeMiscIdUnique 392-conTIdKey           = mkPreludeMiscIdUnique 393-tupleTIdKey         = mkPreludeMiscIdUnique 394-unboxedTupleTIdKey  = mkPreludeMiscIdUnique 395-unboxedSumTIdKey    = mkPreludeMiscIdUnique 396-arrowTIdKey         = mkPreludeMiscIdUnique 397-listTIdKey          = mkPreludeMiscIdUnique 398-appTIdKey           = mkPreludeMiscIdUnique 399-appKindTIdKey       = mkPreludeMiscIdUnique 400-sigTIdKey           = mkPreludeMiscIdUnique 401-equalityTIdKey      = mkPreludeMiscIdUnique 402-litTIdKey           = mkPreludeMiscIdUnique 403-promotedTIdKey      = mkPreludeMiscIdUnique 404-promotedTupleTIdKey = mkPreludeMiscIdUnique 405-promotedNilTIdKey   = mkPreludeMiscIdUnique 406-promotedConsTIdKey  = mkPreludeMiscIdUnique 407-wildCardTIdKey      = mkPreludeMiscIdUnique 408-implicitParamTIdKey = mkPreludeMiscIdUnique 409-infixTIdKey         = mkPreludeMiscIdUnique 410---- data TyLit = ...-numTyLitIdKey, strTyLitIdKey, charTyLitIdKey :: Unique-numTyLitIdKey  = mkPreludeMiscIdUnique 411-strTyLitIdKey  = mkPreludeMiscIdUnique 412-charTyLitIdKey = mkPreludeMiscIdUnique 413---- data TyVarBndr = ...-plainTVIdKey, kindedTVIdKey :: Unique-plainTVIdKey       = mkPreludeMiscIdUnique 414-kindedTVIdKey      = mkPreludeMiscIdUnique 415--plainInvisTVIdKey, kindedInvisTVIdKey :: Unique-plainInvisTVIdKey       = mkPreludeMiscIdUnique 482-kindedInvisTVIdKey      = mkPreludeMiscIdUnique 483--plainBndrTVIdKey, kindedBndrTVIdKey :: Unique-plainBndrTVIdKey       = mkPreludeMiscIdUnique 484-kindedBndrTVIdKey      = mkPreludeMiscIdUnique 485---- data Role = ...-nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique-nominalRIdKey          = mkPreludeMiscIdUnique 416-representationalRIdKey = mkPreludeMiscIdUnique 417-phantomRIdKey          = mkPreludeMiscIdUnique 418-inferRIdKey            = mkPreludeMiscIdUnique 419---- data Kind = ...-starKIdKey, constraintKIdKey :: Unique-starKIdKey        = mkPreludeMiscIdUnique 425-constraintKIdKey  = mkPreludeMiscIdUnique 426---- data FamilyResultSig = ...-noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique-noSigIdKey        = mkPreludeMiscIdUnique 427-kindSigIdKey      = mkPreludeMiscIdUnique 428-tyVarSigIdKey     = mkPreludeMiscIdUnique 429---- data InjectivityAnn = ...-injectivityAnnIdKey :: Unique-injectivityAnnIdKey = mkPreludeMiscIdUnique 430---- data Callconv = ...-cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,-  javaScriptCallIdKey :: Unique-cCallIdKey          = mkPreludeMiscIdUnique 431-stdCallIdKey        = mkPreludeMiscIdUnique 432-cApiCallIdKey       = mkPreludeMiscIdUnique 433-primCallIdKey       = mkPreludeMiscIdUnique 434-javaScriptCallIdKey = mkPreludeMiscIdUnique 435---- data Safety = ...-unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique-unsafeIdKey        = mkPreludeMiscIdUnique 440-safeIdKey          = mkPreludeMiscIdUnique 441-interruptibleIdKey = mkPreludeMiscIdUnique 442---- data FunDep = ...-funDepIdKey :: Unique-funDepIdKey = mkPreludeMiscIdUnique 445---- mulArrow-mulArrowTIdKey :: Unique-mulArrowTIdKey = mkPreludeMiscIdUnique 446---- data TySynEqn = ...-tySynEqnIdKey :: Unique-tySynEqnIdKey = mkPreludeMiscIdUnique 460---- quasiquoting-quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique-quoteExpKey  = mkPreludeMiscIdUnique 470-quotePatKey  = mkPreludeMiscIdUnique 471-quoteDecKey  = mkPreludeMiscIdUnique 472-quoteTypeKey = mkPreludeMiscIdUnique 473---- data RuleBndr = ...-ruleVarIdKey, typedRuleVarIdKey :: Unique-ruleVarIdKey      = mkPreludeMiscIdUnique 480-typedRuleVarIdKey = mkPreludeMiscIdUnique 481---- data AnnTarget = ...-valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique-valueAnnotationIdKey  = mkPreludeMiscIdUnique 490-typeAnnotationIdKey   = mkPreludeMiscIdUnique 491-moduleAnnotationIdKey = mkPreludeMiscIdUnique 492---- type DerivPred = ...-derivClauseIdKey :: Unique-derivClauseIdKey = mkPreludeMiscIdUnique 493---- data DerivStrategy = ...-stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey,-  viaStrategyIdKey :: Unique-stockStrategyIdKey    = mkPreludeDataConUnique 494-anyclassStrategyIdKey = mkPreludeDataConUnique 495-newtypeStrategyIdKey  = mkPreludeDataConUnique 496-viaStrategyIdKey      = mkPreludeDataConUnique 497---- data Specificity = ...-specifiedSpecKey, inferredSpecKey :: Unique-specifiedSpecKey = mkPreludeMiscIdUnique 498-inferredSpecKey  = mkPreludeMiscIdUnique 499---- data BndrVis = ...-bndrReqKey, bndrInvisKey :: Unique-bndrReqKey   = mkPreludeMiscIdUnique 800  -- TODO (int-index): make up some room in the 5** numberspace?-bndrInvisKey = mkPreludeMiscIdUnique 801--{--************************************************************************-*                                                                      *-                        RdrNames-*                                                                      *-************************************************************************--}--lift_RDR, liftTyped_RDR, unsafeCodeCoerce_RDR :: RdrName-lift_RDR     = nameRdrName liftName-liftTyped_RDR = nameRdrName liftTypedName-unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName
− compiler/GHC/Builtin/Utils.hs 
@@ -1,341 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}------ | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge.------ This module serves as the central gathering point for names which the--- compiler knows something about. This includes functions for,------  * discerning whether a 'Name' is known-key------  * given a 'Unique', looking up its corresponding known-key 'Name'------ See Note [Known-key names] and Note [About wired-in things] for information--- about the two types of prelude things in GHC.----module GHC.Builtin.Utils (-        -- * Known-key names-        isKnownKeyName,-        lookupKnownKeyName,-        lookupKnownNameInfo,--        -- ** Internal use-        -- | 'knownKeyNames' is exported to seed the original name cache only;-        -- if you find yourself wanting to look at it you might consider using-        -- 'lookupKnownKeyName' or 'isKnownKeyName'.-        knownKeyNames,--        -- * Miscellaneous-        wiredInIds, ghcPrimIds,--        ghcPrimExports,-        ghcPrimDeclDocs,-        ghcPrimWarns,-        ghcPrimFixities,--        -- * Random other things-        maybeCharLikeCon, maybeIntLikeCon,--        -- * Class categories-        isNumericClass, isStandardClass--    ) where--import GHC.Prelude--import GHC.Builtin.Uniques-import GHC.Builtin.PrimOps-import GHC.Builtin.PrimOps.Ids-import GHC.Builtin.Types-import GHC.Builtin.Types.Literals ( typeNatTyCons )-import GHC.Builtin.Types.Prim-import GHC.Builtin.Names.TH ( templateHaskellNames )-import GHC.Builtin.Names--import GHC.Core.ConLike ( ConLike(..) )-import GHC.Core.DataCon-import GHC.Core.Class-import GHC.Core.TyCon--import GHC.Types.Avail-import GHC.Types.Id-import GHC.Types.Fixity-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Id.Make-import GHC.Types.SourceText-import GHC.Types.Unique.FM-import GHC.Types.Unique.Map-import GHC.Types.TyThing-import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways )--import GHC.Utils.Outputable-import GHC.Utils.Misc as Utils-import GHC.Utils.Panic-import GHC.Utils.Constants (debugIsOn)-import GHC.Parser.Annotation-import GHC.Hs.Doc-import GHC.Unit.Module.ModIface (IfaceExport)-import GHC.Unit.Module.Warnings--import GHC.Data.List.SetOps--import Control.Applicative ((<|>))-import Data.Maybe--{--************************************************************************-*                                                                      *-\subsection[builtinNameInfo]{Lookup built-in names}-*                                                                      *-************************************************************************--Note [About wired-in things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* Wired-in things are Ids\/TyCons that are completely known to the compiler.-  They are global values in GHC, (e.g.  listTyCon :: TyCon).--* A wired-in Name contains the thing itself inside the Name:-        see Name.wiredInNameTyThing_maybe-  (E.g. listTyConName contains listTyCon.--* The name cache is initialised with (the names of) all wired-in things-  (except tuples and sums; see Note [Infinite families of known-key names])--* The type environment itself contains no wired in things. The type-  checker sees if the Name is wired in before looking up the name in-  the type environment.--* GHC.Iface.Make prunes out wired-in things before putting them in an interface file.-  So interface files never contain wired-in things.--}----- | This list is used to ensure that when you say "Prelude.map" in your source--- code, or in an interface file, you get a Name with the correct known key (See--- Note [Known-key names] in "GHC.Builtin.Names")-knownKeyNames :: [Name]-knownKeyNames-  | debugIsOn-  , Just badNamesDoc <- knownKeyNamesOkay all_names-  = pprPanic "badAllKnownKeyNames" badNamesDoc-  | otherwise-  = all_names-  where-    all_names =-      concat [ concatMap wired_tycon_kk_names primTyCons-             , concatMap wired_tycon_kk_names wiredInTyCons-             , concatMap wired_tycon_kk_names typeNatTyCons-             , map idName wiredInIds-             , map idName allThePrimOpIds-             , map (idName . primOpWrapperId) allThePrimOps-             , basicKnownKeyNames-             , templateHaskellNames-             ]-    -- All of the names associated with a wired-in TyCon.-    -- This includes the TyCon itself, its DataCons and promoted TyCons.-    wired_tycon_kk_names :: TyCon -> [Name]-    wired_tycon_kk_names tc =-        tyConName tc : (rep_names tc ++ implicits)-      where implicits = concatMap thing_kk_names (implicitTyConThings tc)--    wired_datacon_kk_names :: DataCon -> [Name]-    wired_datacon_kk_names dc =-      dataConName dc : rep_names (promoteDataCon dc)--    thing_kk_names :: TyThing -> [Name]-    thing_kk_names (ATyCon tc)                 = wired_tycon_kk_names tc-    thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc-    thing_kk_names thing                       = [getName thing]--    -- The TyConRepName for a known-key TyCon has a known key,-    -- but isn't itself an implicit thing.  Yurgh.-    -- NB: if any of the wired-in TyCons had record fields, the record-    --     field names would be in a similar situation.  Ditto class ops.-    --     But it happens that there aren't any-    rep_names tc = case tyConRepName_maybe tc of-                        Just n  -> [n]-                        Nothing -> []---- | Check the known-key names list of consistency.-knownKeyNamesOkay :: [Name] -> Maybe SDoc-knownKeyNamesOkay all_names-  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names-  = Just $ text "    Out-of-range known-key uniques: " <>-           brackets (pprWithCommas (ppr . nameOccName) ns)-  | null badNamesPairs-  = Nothing-  | otherwise-  = Just badNamesDoc-  where-    namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n)-                           emptyUFM all_names-    badNamesEnv   = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv-    badNamesPairs = nonDetUFMToList badNamesEnv-      -- It's OK to use nonDetUFMToList here because the ordering only affects-      -- the message when we get a panic-    badNamesDoc :: SDoc-    badNamesDoc  = vcat $ map pairToDoc badNamesPairs--    pairToDoc :: (Unique, [Name]) -> SDoc-    pairToDoc (uniq, ns) = text "        " <>-                           pprUniqueAlways uniq <>-                           text ": " <>-                           brackets (pprWithCommas (ppr . nameOccName) ns)---- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a--- known-key thing.-lookupKnownKeyName :: Unique -> Maybe Name-lookupKnownKeyName u =-    knownUniqueName u <|> lookupUFM_Directly knownKeysMap u---- | Is a 'Name' known-key?-isKnownKeyName :: Name -> Bool-isKnownKeyName n =-    isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap---- | Maps 'Unique's to known-key names.------ The type is @UniqFM Name Name@ to denote that the 'Unique's used--- in the domain are 'Unique's associated with 'Name's (as opposed--- to some other namespace of 'Unique's).-knownKeysMap :: UniqFM Name Name-knownKeysMap = listToIdentityUFM knownKeyNames---- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by--- GHCi's ':info' command.-lookupKnownNameInfo :: Name -> SDoc-lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of-    -- If we do find a doc, we add comment delimiters to make the output-    -- of ':info' valid Haskell.-    Nothing  -> empty-    Just doc -> vcat [text "{-", doc, text "-}"]---- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390)-knownNamesInfo :: NameEnv SDoc-knownNamesInfo = unitNameEnv coercibleTyConName $-    vcat [ text "Coercible is a special constraint with custom solving rules."-         , text "It is not a class."-         , text "Please see section `The Coercible constraint`"-         , text "of the user's guide for details." ]--{--We let a lot of "non-standard" values be visible, so that we can make-sense of them in interface pragmas. It's cool, though they all have-"non-standard" names, so they won't get past the parser in user code.--}--{--************************************************************************-*                                                                      *-            Export lists for pseudo-modules (GHC.Prim)-*                                                                      *-************************************************************************--}--ghcPrimExports :: [IfaceExport]-ghcPrimExports- = map (Avail . idName) ghcPrimIds ++-   map (Avail . idName) allThePrimOpIds ++-   [ AvailTC n [n]-   | tc <- exposedPrimTyCons, let n = tyConName tc ]--ghcPrimDeclDocs :: Docs-ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs }-  where-    findName (nameStr, doc)-      | Just name <- lookupFsEnv ghcPrimNames nameStr-      = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []])-      | otherwise = Nothing--ghcPrimNames :: FastStringEnv Name-ghcPrimNames-  = mkFsEnv-    [ (occNameFS $ nameOccName name, name)-    | name <--        map idName ghcPrimIds ++-        map idName allThePrimOpIds ++-        map tyConName exposedPrimTyCons-    ]---- See Note [GHC.Prim Deprecations]-ghcPrimWarns :: Warnings a-ghcPrimWarns = WarnSome-  -- declaration warnings-  (map mk_decl_dep primOpDeprecations)-  -- export warnings-  []-  where-    mk_txt msg =-      DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]-    mk_decl_dep (occ, msg) = (occ, mk_txt msg)--ghcPrimFixities :: [(OccName,Fixity)]-ghcPrimFixities = fixities-  where-    -- The fixity listed here for @`seq`@ should match-    -- those in primops.txt.pp (from which Haddock docs are generated).-    fixities = (getOccName seqId, Fixity 0 InfixR)-             : mapMaybe mkFixity allThePrimOps-    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op--{--Note [GHC.Prim Docs]-~~~~~~~~~~~~~~~~~~~~-For haddocks of GHC.Prim we generate a dummy haskell file (gen_hs_source) that-contains the type signatures and the comments (but no implementations)-specifically for consumption by haddock.--GHCi's :doc command reads directly from ModIface's though, and GHC.Prim has a-wired-in iface that has nothing to do with the above haskell file. The code-below converts primops.txt into an intermediate form that would later be turned-into a proper DeclDocMap.--We output the docs as a list of pairs (name, docs). We use stringy names here-because mapping names to "Name"s is difficult for things like primtypes and-pseudoops.--Note [GHC.Prim Deprecations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Like Haddock documentation, we must record deprecation pragmas in two places:-in the GHC.Prim source module consumed by Haddock, and in the-declarations wired-in to GHC. To do the following we generate-GHC.Builtin.PrimOps.primOpDeprecations, a list of (OccName, DeprecationMessage)-pairs. We insert these deprecations into the mi_warns field of GHC.Prim's ModIface,-as though they were written in a source module.--}---{--************************************************************************-*                                                                      *-            Built-in keys-*                                                                      *-************************************************************************--ToDo: make it do the ``like'' part properly (as in 0.26 and before).--}--maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool-maybeCharLikeCon con = con `hasKey` charDataConKey-maybeIntLikeCon  con = con `hasKey` intDataConKey--{--************************************************************************-*                                                                      *-            Class predicates-*                                                                      *-************************************************************************--}--isNumericClass, isStandardClass :: Class -> Bool--isNumericClass     clas = classKey clas `is_elem` numericClassKeys-isStandardClass    clas = classKey clas `is_elem` standardClassKeys--is_elem :: Eq a => a -> [a] -> Bool-is_elem = isIn "is_X_Class"
compiler/GHC/ByteCode/Asm.hs view
@@ -1,27 +1,33 @@ {-# LANGUAGE CPP             #-} {-# LANGUAGE DeriveFunctor   #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MagicHash       #-}+{-# LANGUAGE UnboxedTuples   #-}+{-# LANGUAGE PatternSynonyms   #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --+-- --  (c) The University of Glasgow 2002-2006 --  -- | Bytecode assembler and linker module GHC.ByteCode.Asm (-        assembleBCOs, assembleOneBCO,+        assembleBCOs,         bcoFreeNames,         SizedSeq, sizeSS, ssElts,         iNTERP_STACK_CHECK_THRESH,-        mkNativeCallInfoLit+        mkNativeCallInfoLit,++        -- * For testing+        assembleBCO   ) where -import GHC.Prelude+import GHC.Prelude hiding ( any ) + import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable import GHC.ByteCode.Types-import GHCi.RemoteTypes-import GHC.Runtime.Interpreter import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord )  import GHC.Types.Name@@ -29,13 +35,15 @@ import GHC.Types.Literal import GHC.Types.Unique.DSet import GHC.Types.SptEntry+import GHC.Types.Unique.FM+import GHC.Unit.Types  import GHC.Utils.Outputable import GHC.Utils.Panic  import GHC.Core.TyCon-import GHC.Data.FlatBag import GHC.Data.SizedSeq+import GHC.Data.SmallArray  import GHC.StgToCmm.Layout     ( ArgRep(..) ) import GHC.Cmm.Expr@@ -43,22 +51,29 @@ import GHC.Cmm.CallConv        ( allArgRegsCover ) import GHC.Platform import GHC.Platform.Profile+import Language.Haskell.Syntax.Module.Name  import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.State.Strict+import qualified Control.Monad.Trans.State.Strict as MTL  import qualified Data.Array.Unboxed as Array-import Data.Array.Base  ( UArray(..) )+import qualified Data.Array.IO as Array+import Data.Array.Base  ( UArray(..), numElements, unsafeFreeze ) +#if ! defined(DEBUG)+import Data.Array.Base  ( unsafeWrite )+#endif+ import Foreign hiding (shiftL, shiftR)-import Data.Char        ( ord )-import Data.List        ( genericLength )-import Data.Map.Strict (Map)+import Data.ByteString (ByteString)+import Data.Char  (ord) import Data.Maybe (fromMaybe)-import qualified Data.Map.Strict as Map import GHC.Float (castFloatToWord32, castDoubleToWord64) +import qualified Data.List as List ( any )+import GHC.Exts++ -- ----------------------------------------------------------------------------- -- Unlinked BCOs @@ -90,24 +105,21 @@  -- Top level assembler fn. assembleBCOs-  :: Interp-  -> Profile+  :: Profile   -> FlatBag (ProtoBCO Name)   -> [TyCon]-  -> AddrEnv-  -> Maybe ModBreaks+  -> [(Name, ByteString)]+  -> Maybe InternalModBreaks   -> [SptEntry]   -> IO CompiledByteCode-assembleBCOs interp profile proto_bcos tycons top_strs modbreaks spt_entries = do+assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do   -- TODO: the profile should be bundled with the interpreter: the rts ways are   -- fixed for an interpreter-  itblenv <- mkITbls interp profile tycons+  let itbls = mkITbls profile tycons   bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos-  bcos'   <- mallocStrings interp bcos   return CompiledByteCode-    { bc_bcos = bcos'-    , bc_itbls =  itblenv-    , bc_ffis = concatMap protoBCOFFIs proto_bcos+    { bc_bcos = bcos+    , bc_itbls = itbls     , bc_strs = top_strs     , bc_breaks = modbreaks     , bc_spt_entries = spt_entries@@ -123,70 +135,75 @@ -- memory for them, and bake the resulting addresses into the instruction stream -- in the form of BCONPtrWord arguments. ----- Since we do this when assembling, we only allocate the memory when we compile--- the module, not each time we relink it. However, we do want to take care to--- malloc the memory all in one go, since that is more efficient with--- -fexternal-interpreter, especially when compiling in parallel.+-- We used to allocate remote buffers for BCONPtrStr ByteStrings when+-- assembling, but this gets in the way of bytecode serialization: we+-- want the ability to serialize and reload assembled bytecode, so+-- it's better to preserve BCONPtrStr as-is, and only perform the+-- actual allocation at link-time. -- -- Note that, as with top-level string literal bindings, this memory is never -- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for -- top-level string literal bindings] in GHC.StgToByteCode for some discussion -- about why. ---mallocStrings ::  Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO)-mallocStrings interp ulbcos = do-  let bytestrings = reverse (execState (mapM_ collect ulbcos) [])-  ptrs <- interpCmd interp (MallocStrings bytestrings)-  return (evalState (mapM splice ulbcos) ptrs)- where-  splice bco@UnlinkedBCO{..} = do-    lits <- mapM spliceLit unlinkedBCOLits-    ptrs <- mapM splicePtr unlinkedBCOPtrs-    return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs } -  spliceLit (BCONPtrStr _) = do-    rptrs <- get-    case rptrs of-      (RemotePtr p : rest) -> do-        put rest-        return (BCONPtrWord (fromIntegral p))-      _ -> panic "mallocStrings:spliceLit"-  spliceLit other = return other+data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16)+                                  , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)+                                  , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr )+                                  } -  splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco-  splicePtr other = return other+data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16)+                                 , final_ptr_array :: !(SmallArray BCOPtr)+                                 , final_lit_array :: !(SmallArray BCONPtr) } -  collect UnlinkedBCO{..} = do-    mapM_ collectLit unlinkedBCOLits-    mapM_ collectPtr unlinkedBCOPtrs+-- How many words we have written so far.+data AsmState = AsmState { nisn :: !Int, nptr :: !Int, nlit :: !Int } -  collectLit (BCONPtrStr bs) = do-    strs <- get-    put (bs:strs)-  collectLit _ = return () -  collectPtr (BCOPtrBCO bco) = collect bco-  collectPtr _ = return ()+{-# NOINLINE inspectInstrs #-}+-- | Perform analysis of the bytecode to determine+--  1. How many instructions we will produce+--  2. If we are going to need long jumps.+--  3. The offsets that labels refer to+inspectInstrs :: Platform -> Bool -> Word -> [BCInstr] -> InspectState+inspectInstrs platform long_jump e instrs =+  inspectAsm long_jump e (mapM_ (assembleInspectAsm platform) instrs) +{-# NOINLINE runInstrs #-}+-- | Assemble the bytecode from the instructions.+runInstrs ::  Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult+runInstrs platform long_jumps is_state instrs = do+  -- Produce arrays of exactly the right size, corresponding to the result of inspectInstrs.+  isn_array <- Array.newArray_ (0, (fromIntegral $ instrCount is_state) - 1)+  ptr_array <- newSmallArrayIO (fromIntegral $ ptrCount is_state) undefined+  lit_array <- newSmallArrayIO (fromIntegral $ litCount is_state) undefined+  let env :: LocalLabel -> Word+      env lbl = fromMaybe+        (pprPanic "assembleBCO.findLabel" (ppr lbl))+        (lookupUFM (lblEnv is_state) lbl)+  let initial_state  = AsmState 0 0 0+  let initial_reader = RunAsmReader{..}+  runAsm long_jumps env initial_reader initial_state (mapM_ (\i -> assembleRunAsm platform i) instrs)+  final_isn_array <- unsafeFreeze isn_array+  final_ptr_array <- unsafeFreezeSmallArrayIO ptr_array+  final_lit_array <- unsafeFreezeSmallArrayIO lit_array+  return $ RunAsmResult {..} -assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO-assembleOneBCO interp profile pbco = do-  -- TODO: the profile should be bundled with the interpreter: the rts ways are-  -- fixed for an interpreter-  ubco <- assembleBCO (profilePlatform profile) pbco-  UnitFlatBag ubco' <- mallocStrings interp (UnitFlatBag ubco)-  return ubco'+assembleRunAsm :: Platform -> BCInstr -> RunAsm ()+assembleRunAsm p i = assembleI @RunAsm p i +assembleInspectAsm :: Platform -> BCInstr -> InspectAsm ()+assembleInspectAsm p i = assembleI @InspectAsm p i+ assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO-assembleBCO platform (ProtoBCO { protoBCOName       = nm-                             , protoBCOInstrs     = instrs-                             , protoBCOBitmap     = bitmap-                             , protoBCOBitmapSize = bsize-                             , protoBCOArity      = arity }) = do+assembleBCO platform+            (ProtoBCO { protoBCOName       = nm+                      , protoBCOInstrs     = instrs+                      , protoBCOBitmap     = bitmap+                      , protoBCOBitmapSize = bsize+                      , protoBCOArity      = arity }) = do   -- pass 1: collect up the offsets of the local labels.-  let asm = mapM_ (assembleI platform) instrs--      initial_offset = 0+  let initial_offset = 0        -- Jump instructions are variable-sized, there are long and short variants       -- depending on the magnitude of the offset.  However, we can't tell what@@ -196,30 +213,31 @@       -- and if the final size is indeed small enough for short jumps, we are       -- done.  Otherwise, we repeat the calculation, and we force all jumps in       -- this BCO to be long.-      (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm-      ((n_insns, lbl_map), long_jumps)-        | isLargeW (fromIntegral $ Map.size lbl_map0)-          || isLargeW n_insns0-                    = (inspectAsm platform True initial_offset asm, True)-        | otherwise = ((n_insns0, lbl_map0), False)+      is0 = inspectInstrs platform False initial_offset instrs+      (is1, long_jumps)+        | isLargeInspectState is0+                    = (inspectInstrs platform True initial_offset instrs, True)+        | otherwise = (is0, False) -      env :: LocalLabel -> Word-      env lbl = fromMaybe-        (pprPanic "assembleBCO.findLabel" (ppr lbl))-        (Map.lookup lbl lbl_map)    -- pass 2: run assembler and generate instructions, literals and pointers-  let initial_state = (emptySS, emptySS, emptySS)-  (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm+  RunAsmResult{..} <- runInstrs platform long_jumps is1 instrs    -- precomputed size should be equal to final size-  massertPpr (n_insns == sizeSS final_insns)+  massertPpr (fromIntegral (instrCount is1) == numElements final_isn_array+              && fromIntegral (ptrCount is1) == sizeofSmallArray final_ptr_array+              && fromIntegral (litCount is1) == sizeofSmallArray final_lit_array)              (text "bytecode instruction count mismatch") -  let asm_insns = ssElts final_insns-      !insns_arr =  mkBCOByteArray $ Array.listArray (0 :: Int, fromIntegral n_insns - 1) asm_insns+  let !insns_arr =  mkBCOByteArray $ final_isn_array       !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap-      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSizedSeq final_lits) (fromSizedSeq final_ptrs)+      ul_bco = UnlinkedBCO { unlinkedBCOName = nm+                           , unlinkedBCOArity = arity+                           , unlinkedBCOInstrs = insns_arr+                           , unlinkedBCOBitmap = bitmap_arr+                           , unlinkedBCOLits = fromSmallArray final_lit_array+                           , unlinkedBCOPtrs = fromSmallArray final_ptr_array+                           }    -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive   -- objects, since they might get run too early.  Disable this until@@ -228,6 +246,7 @@    return ul_bco +-- | Construct a word-array containing an @StgLargeBitmap@. mkBitmapArray :: Word -> [StgWord] -> UArray Int Word -- Here the return type must be an array of Words, not StgWords, -- because the underlying ByteArray# will end up as a component@@ -236,10 +255,6 @@   = Array.listArray (0, length bitmap) $       fromIntegral bsize : map (fromInteger . fromStgWord) bitmap --- instrs nonptrs ptrs-type AsmState = (SizedSeq Word16,-                 SizedSeq BCONPtr,-                 SizedSeq BCOPtr)  data Operand   = Op Word@@ -259,40 +274,10 @@   PW8 | w <= 4294967295 -> Op (fromIntegral w)   _ -> pprPanic "GHC.ByteCode.Asm.truncHalfWord" (ppr w) -data Assembler a-  = AllocPtr (IO BCOPtr) (Word -> Assembler a)-  | AllocLit [BCONPtr] (Word -> Assembler a)-  | AllocLabel LocalLabel (Assembler a)-  | Emit Word16 [Operand] (Assembler a)-  | NullAsm a-  deriving (Functor) -instance Applicative Assembler where-    pure = NullAsm-    (<*>) = ap--instance Monad Assembler where-  NullAsm x >>= f = f x-  AllocPtr p k >>= f = AllocPtr p (k >=> f)-  AllocLit l k >>= f = AllocLit l (k >=> f)-  AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f)-  Emit w ops k >>= f = Emit w ops (k >>= f)--ioptr :: IO BCOPtr -> Assembler Word-ioptr p = AllocPtr p return--ptr :: BCOPtr -> Assembler Word+ptr :: MonadAssembler m => BCOPtr -> m Word ptr = ioptr . return -lit :: [BCONPtr] -> Assembler Word-lit l = AllocLit l return--label :: LocalLabel -> Assembler ()-label w = AllocLabel w (return ())--emit :: Word16 -> [Operand] -> Assembler ()-emit w ops = Emit w ops (return ())- type LabelEnv = LocalLabel -> Word  largeOp :: Bool -> Operand -> Bool@@ -302,39 +287,143 @@    IOp i     -> isLargeI i    LabelOp _ -> long_jumps -runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a-runAsm platform long_jumps e = go+newtype RunAsm a = RunAsm' { runRunAsm :: Bool+                                       -> LabelEnv+                                       -> RunAsmReader+                                       -> AsmState+                                       -> IO (AsmState, a) }++pattern RunAsm :: (Bool -> LabelEnv -> RunAsmReader -> AsmState -> IO (AsmState, a))+                  -> RunAsm a+pattern RunAsm m <- RunAsm' m   where-    go (NullAsm x) = return x-    go (AllocPtr p_io k) = do-      p <- lift p_io-      w <- state $ \(st_i0,st_l0,st_p0) ->-        let st_p1 = addToSS st_p0 p-        in (sizeSS st_p0, (st_i0,st_l0,st_p1))-      go $ k w-    go (AllocLit lits k) = do-      w <- state $ \(st_i0,st_l0,st_p0) ->-        let st_l1 = addListToSS st_l0 lits-        in (sizeSS st_l0, (st_i0,st_l1,st_p0))-      go $ k w-    go (AllocLabel _ k) = go k-    go (Emit w ops k) = do-      let largeArgs = any (largeOp long_jumps) ops-          opcode-            | largeArgs = largeArgInstr w-            | otherwise = w-          words = concatMap expand ops-          expand (SmallOp w) = [w]-          expand (LabelOp w) = expand (Op (e w))-          expand (Op w) = if largeArgs then largeArg platform (fromIntegral w) else [fromIntegral w]-          expand (IOp i) = if largeArgs then largeArg platform (fromIntegral i) else [fromIntegral i]-      state $ \(st_i0,st_l0,st_p0) ->-        let st_i1 = addListToSS st_i0 (opcode : words)-        in ((), (st_i1,st_l0,st_p0))-      go k+    RunAsm m = RunAsm' (oneShot $ \a -> oneShot $ \b -> oneShot $ \c -> oneShot $ \d -> m a b c d)+{-# COMPLETE RunAsm #-} -type LabelEnvMap = Map LocalLabel Word+instance Functor RunAsm where+  fmap f (RunAsm x) = RunAsm (\a b c !s -> fmap (fmap f) (x a b c s)) +instance Applicative RunAsm where+  pure x = RunAsm $ \_ _ _ !s -> pure (s, x)+  (RunAsm f) <*> (RunAsm x) = RunAsm $ \a b c !s -> do+                                  (!s', f') <- f a b c s+                                  (!s'', x') <- x a b c s'+                                  return (s'', f' x')+  {-# INLINE (<*>) #-}+++instance Monad RunAsm where+  return  = pure+  (RunAsm m) >>= f = RunAsm $ \a b c !s -> m a b c s >>= \(s', r) -> runRunAsm (f r) a b c s'+  {-# INLINE (>>=) #-}++runAsm :: Bool -> LabelEnv -> RunAsmReader -> AsmState -> RunAsm a -> IO a+runAsm long_jumps e r s (RunAsm'{runRunAsm}) = fmap snd $ runRunAsm long_jumps e r s++expand :: PlatformWordSize -> Bool -> Operand -> RunAsm ()+expand word_size largeArgs o = do+  e <- askEnv+  case o of+    (SmallOp w) -> writeIsn w+    (LabelOp w) -> let !r = e w in handleLargeArg r+    (Op w) -> handleLargeArg w+    (IOp i) -> handleLargeArg i++  where+    handleLargeArg :: Integral a => a -> RunAsm ()+    handleLargeArg w  =+      if largeArgs+        then largeArg word_size (fromIntegral w)+        else writeIsn (fromIntegral w)++lift :: IO a -> RunAsm a+lift io = RunAsm $ \_ _ _ s -> io >>= \a -> pure (s, a)++askLongJumps :: RunAsm Bool+askLongJumps = RunAsm $ \a _ _ s -> pure (s, a)++askEnv :: RunAsm LabelEnv+askEnv = RunAsm $ \_ b _ s -> pure (s, b)++writePtr :: BCOPtr -> RunAsm Word+writePtr w+            = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do+              writeSmallArrayIO ptr_array (nptr asm) w+              let !n' = nptr asm + 1+              let !asm' = asm { nptr = n' }+              return (asm', fromIntegral (nptr asm))++writeLit :: BCONPtr -> RunAsm Word+writeLit w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do+              writeSmallArrayIO lit_array (nlit asm) w+              let !n' = nlit asm + 1+              let !asm' = asm { nlit = n' }+              return (asm', fromIntegral (nlit asm))++writeLits :: OneOrTwo BCONPtr -> RunAsm Word+writeLits (OnlyOne l) = writeLit l+writeLits (OnlyTwo l1 l2) = writeLit l1 <* writeLit l2++writeIsn :: Word16 -> RunAsm ()+writeIsn w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do+#if defined(DEBUG)+              Array.writeArray isn_array (nisn asm) w+#else+              unsafeWrite isn_array (nisn asm) w+#endif+              let !n' = nisn asm + 1+              let !asm' = asm { nisn = n' }+              return (asm', ())++{-# INLINE any #-}+-- Any is unrolled manually so that the call in `emit` can be eliminated without+-- relying on SpecConstr (which does not work across modules).+any :: (a -> Bool) -> [a] -> Bool+any _ [] = False+any f [x] = f x+any f [x,y] = f x || f y+any f [x,y,z] = f x || f y || f z+any f [x1,x2,x3,x4] = f x1 || f x2 || f x3 || f x4+any f [x1,x2,x3,x4, x5] = f x1 || f x2 || f x3 || f x4 || f x5+any f [x1,x2,x3,x4,x5,x6] = f x1 || f x2 || f x3 || f x4 || f x5 || f x6+any f xs = List.any f xs++{-# INLINE mapM6_ #-}+mapM6_ :: Monad m => (a -> m b) -> [a] -> m ()+mapM6_ _ [] = return ()+mapM6_ f [x] = () <$ f x+mapM6_ f [x,y] = () <$ f x <* f y+mapM6_ f [x,y,z] = () <$ f x <* f y <* f z+mapM6_ f [a1,a2,a3,a4] = () <$ f a1 <* f a2 <* f a3 <* f a4+mapM6_ f [a1,a2,a3,a4,a5] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5+mapM6_ f [a1,a2,a3,a4,a5,a6] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5 <* f a6+mapM6_ f xs = mapM_ f xs++instance MonadAssembler RunAsm where+  ioptr p_io = do+    p <- lift p_io+    writePtr p+  lit lits = writeLits lits++  label _ = return ()++  emit pwordsize w ops = do+    long_jumps <- askLongJumps+    -- See the definition of `any` above+    let largeArgs = any (largeOp long_jumps) ops+    let opcode+          | largeArgs = largeArgInstr w+          | otherwise = w+    writeIsn opcode+    mapM6_ (expand pwordsize largeArgs) ops++  {-# INLINE emit #-}+  {-# INLINE label #-}+  {-# INLINE lit #-}+  {-# INLINE ioptr #-}++type LabelEnvMap = UniqFM LocalLabel Word+ data InspectState = InspectState   { instrCount :: !Word   , ptrCount :: !Word@@ -342,74 +431,173 @@   , lblEnv :: LabelEnvMap   } -inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)-inspectAsm platform long_jumps initial_offset-  = go (InspectState initial_offset 0 0 Map.empty)+instance Outputable InspectState where+  ppr (InspectState i p l m) = text "InspectState" <+> ppr [ppr i, ppr p, ppr l, ppr (sizeUFM m)]++isLargeInspectState :: InspectState -> Bool+isLargeInspectState InspectState{..} =+  isLargeW (fromIntegral $ sizeUFM lblEnv)+    || isLargeW instrCount++newtype InspectEnv = InspectEnv { _inspectLongJumps :: Bool+                                }++newtype InspectAsm a = InspectAsm' { runInspectAsm :: InspectEnv -> InspectState -> (# InspectState,  a #) }++pattern InspectAsm :: (InspectEnv -> InspectState -> (# InspectState, a #))+                   -> InspectAsm a+pattern InspectAsm m <- InspectAsm' m   where-    go s (NullAsm _) = (instrCount s, lblEnv s)-    go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)-      where n = ptrCount s-    go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)-      where n = litCount s-    go s (AllocLabel lbl k) = go s' k-      where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }-    go s (Emit _ ops k) = go s' k-      where-        s' = s { instrCount = instrCount s + size }-        size = sum (map count ops) + 1+    InspectAsm m = InspectAsm' (oneShot $ \a -> oneShot $ \b -> m a b)+{-# COMPLETE InspectAsm #-}++instance Functor InspectAsm where+  fmap f (InspectAsm k) = InspectAsm $ \a b -> case k a b of+                                                  (# b', c #) -> (# b', f c #)++instance Applicative InspectAsm where+  pure x = InspectAsm $ \_ s -> (# s, x #)+  (InspectAsm f) <*> (InspectAsm x) = InspectAsm $ \a b -> case f a b of+                                                              (# s', f' #) ->+                                                                case x a s' of+                                                                  (# s'', x' #) -> (# s'', f' x' #)++instance Monad InspectAsm where+  return = pure+  (InspectAsm m) >>= f = InspectAsm $ \ a b -> case m a b of+                                                (# s', a' #) -> runInspectAsm (f a') a s'++get_ :: InspectAsm InspectState+get_ = InspectAsm $ \_ b -> (# b, b #)++put_ :: InspectState -> InspectAsm ()+put_ !s = InspectAsm $ \_ _ -> (# s, () #)++modify_ :: (InspectState -> InspectState) -> InspectAsm ()+modify_ f = InspectAsm $ \_ s -> let !s' = f s in (# s', () #)++ask_ :: InspectAsm InspectEnv+ask_ = InspectAsm $ \a b -> (# b, a #)++inspectAsm :: Bool -> Word -> InspectAsm () -> InspectState+inspectAsm long_jumps initial_offset (InspectAsm s) =+  case s (InspectEnv long_jumps) (InspectState initial_offset 0 0 emptyUFM) of+    (# res, () #) -> res+{-# INLINE inspectAsm #-}++++instance MonadAssembler InspectAsm where+  ioptr _ = do+    s <- get_+    let n = ptrCount s+    put_ (s { ptrCount = n + 1 })+    return n++  lit ls = do+    s <- get_+    let n = litCount s+    put_ (s { litCount = n + oneTwoLength ls })+    return n++  label lbl = modify_ (\s -> let !count = instrCount s in let !env' = addToUFM (lblEnv s) lbl count in s { lblEnv = env' })++  emit pwordsize _ ops = do+    InspectEnv long_jumps <- ask_+    -- Size is written in this way as `mapM6_` is also used by RunAsm, and guaranteed+    -- to unroll for arguments up to size 6.+    let size = (MTL.execState (mapM6_ (\x -> MTL.modify (count' x +)) ops) 0) + 1         largeOps = any (largeOp long_jumps) ops-        count (SmallOp _) = 1-        count (LabelOp _) = count (Op 0)-        count (Op _) = if largeOps then largeArg16s platform else 1-        count (IOp _) = if largeOps then largeArg16s platform else 1+        bigSize = largeArg16s pwordsize+        count' = if largeOps then countLarge bigSize else countSmall bigSize +    s <- get_+    put_ (s { instrCount = instrCount s + size })++  {-# INLINE emit #-}+  {-# INLINE label #-}+  {-# INLINE lit #-}+  {-# INLINE ioptr #-}++count :: Word -> Bool -> Operand -> Word+count _ _ (SmallOp _)          = 1+count big largeOps (LabelOp _) = if largeOps then big else 1+count big largeOps (Op _)      = if largeOps then big else 1+count big largeOps (IOp _)     = if largeOps then big else 1+{-# INLINE count #-}++countSmall, countLarge :: Word -> Operand -> Word+countLarge big x = count big True x+countSmall big x = count big False x++ -- Bring in all the bci_ bytecode constants. #include "Bytecodes.h"  largeArgInstr :: Word16 -> Word16 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci -largeArg :: Platform -> Word64 -> [Word16]-largeArg platform w = case platformWordSize platform of-   PW8 -> [fromIntegral (w `shiftR` 48),-           fromIntegral (w `shiftR` 32),-           fromIntegral (w `shiftR` 16),-           fromIntegral w]+{-# INLINE largeArg #-}+largeArg :: PlatformWordSize -> Word64 -> RunAsm ()+largeArg wsize w = case wsize of+   PW8 ->  do writeIsn (fromIntegral (w `shiftR` 48))+              writeIsn (fromIntegral (w `shiftR` 32))+              writeIsn (fromIntegral (w `shiftR` 16))+              writeIsn (fromIntegral w)    PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32))-                    (text "largeArg too big:" <+> ppr w) $-          [fromIntegral (w `shiftR` 16),-           fromIntegral w]+                    (text "largeArg too big:" <+> ppr w) $ do+          writeIsn (fromIntegral (w `shiftR` 16))+          writeIsn (fromIntegral w) -largeArg16s :: Platform -> Word-largeArg16s platform = case platformWordSize platform of+largeArg16s :: PlatformWordSize -> Word+largeArg16s pwordsize = case pwordsize of    PW8 -> 4    PW4 -> 2 -assembleI :: Platform+data OneOrTwo a = OnlyOne a | OnlyTwo a a deriving (Functor)++oneTwoLength :: OneOrTwo a -> Word+oneTwoLength (OnlyOne {}) = 1+oneTwoLength (OnlyTwo {}) = 2++class Monad m => MonadAssembler m where+  ioptr :: IO BCOPtr -> m Word+  lit :: OneOrTwo BCONPtr -> m Word+  label :: LocalLabel -> m ()+  emit :: PlatformWordSize -> Word16 -> [Operand] -> m ()++lit1 :: MonadAssembler m => BCONPtr -> m Word+lit1 p = lit (OnlyOne p)++{-# SPECIALISE assembleI :: Platform -> BCInstr -> InspectAsm () #-}+{-# SPECIALISE assembleI :: Platform -> BCInstr -> RunAsm () #-}++assembleI :: forall m . MonadAssembler m+          => Platform           -> BCInstr-          -> Assembler ()+          -> m () assembleI platform i = case i of-  STKCHECK n               -> emit bci_STKCHECK [Op n]-  PUSH_L o1                -> emit bci_PUSH_L [wOp o1]-  PUSH_LL o1 o2            -> emit bci_PUSH_LL [wOp o1, wOp o2]-  PUSH_LLL o1 o2 o3        -> emit bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]-  PUSH8 o1                 -> emit bci_PUSH8 [bOp o1]-  PUSH16 o1                -> emit bci_PUSH16 [bOp o1]-  PUSH32 o1                -> emit bci_PUSH32 [bOp o1]-  PUSH8_W o1               -> emit bci_PUSH8_W [bOp o1]-  PUSH16_W o1              -> emit bci_PUSH16_W [bOp o1]-  PUSH32_W o1              -> emit bci_PUSH32_W [bOp o1]+  STKCHECK n               -> emit_ bci_STKCHECK [Op n]+  PUSH_L o1                -> emit_ bci_PUSH_L [wOp o1]+  PUSH_LL o1 o2            -> emit_ bci_PUSH_LL [wOp o1, wOp o2]+  PUSH_LLL o1 o2 o3        -> emit_ bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]+  PUSH8 o1                 -> emit_ bci_PUSH8 [bOp o1]+  PUSH16 o1                -> emit_ bci_PUSH16 [bOp o1]+  PUSH32 o1                -> emit_ bci_PUSH32 [bOp o1]+  PUSH8_W o1               -> emit_ bci_PUSH8_W [bOp o1]+  PUSH16_W o1              -> emit_ bci_PUSH16_W [bOp o1]+  PUSH32_W o1              -> emit_ bci_PUSH32_W [bOp o1]   PUSH_G nm                -> do p <- ptr (BCOPtrName nm)-                                 emit bci_PUSH_G [Op p]+                                 emit_ bci_PUSH_G [Op p]   PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)-                                 emit bci_PUSH_G [Op p]+                                 emit_ bci_PUSH_G [Op p]   PUSH_BCO proto           -> do let ul_bco = assembleBCO platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)-                                 emit bci_PUSH_G [Op p]+                                 emit_ bci_PUSH_G [Op p]   PUSH_ALTS proto pk                            -> do let ul_bco = assembleBCO platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)-                                 emit (push_alts pk) [Op p]+                                 emit_ (push_alts pk) [Op p]   PUSH_ALTS_TUPLE proto call_info tuple_proto                            -> do let ul_bco = assembleBCO platform proto                                      ul_tuple_bco = assembleBCO platform@@ -418,123 +606,274 @@                                  p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)                                  info <- word (fromIntegral $                                               mkNativeCallInfoSig platform call_info)-                                 emit bci_PUSH_ALTS_T+                                 emit_ bci_PUSH_ALTS_T                                       [Op p, Op info, Op p_tup]-  PUSH_PAD8                -> emit bci_PUSH_PAD8 []-  PUSH_PAD16               -> emit bci_PUSH_PAD16 []-  PUSH_PAD32               -> emit bci_PUSH_PAD32 []+  PUSH_PAD8                -> emit_ bci_PUSH_PAD8 []+  PUSH_PAD16               -> emit_ bci_PUSH_PAD16 []+  PUSH_PAD32               -> emit_ bci_PUSH_PAD32 []   PUSH_UBX8 lit            -> do np <- literal lit-                                 emit bci_PUSH_UBX8 [Op np]+                                 emit_ bci_PUSH_UBX8 [Op np]   PUSH_UBX16 lit           -> do np <- literal lit-                                 emit bci_PUSH_UBX16 [Op np]+                                 emit_ bci_PUSH_UBX16 [Op np]   PUSH_UBX32 lit           -> do np <- literal lit-                                 emit bci_PUSH_UBX32 [Op np]+                                 emit_ bci_PUSH_UBX32 [Op np]   PUSH_UBX lit nws         -> do np <- literal lit-                                 emit bci_PUSH_UBX [Op np, wOp nws]-+                                 emit_ bci_PUSH_UBX [Op np, wOp nws]   -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode-  PUSH_ADDR nm             -> do np <- lit [BCONPtrAddr nm]-                                 emit bci_PUSH_UBX [Op np, SmallOp 1]+  PUSH_ADDR nm             -> do np <- lit1 (BCONPtrAddr nm)+                                 emit_ bci_PUSH_UBX [Op np, SmallOp 1] -  PUSH_APPLY_N             -> emit bci_PUSH_APPLY_N []-  PUSH_APPLY_V             -> emit bci_PUSH_APPLY_V []-  PUSH_APPLY_F             -> emit bci_PUSH_APPLY_F []-  PUSH_APPLY_D             -> emit bci_PUSH_APPLY_D []-  PUSH_APPLY_L             -> emit bci_PUSH_APPLY_L []-  PUSH_APPLY_P             -> emit bci_PUSH_APPLY_P []-  PUSH_APPLY_PP            -> emit bci_PUSH_APPLY_PP []-  PUSH_APPLY_PPP           -> emit bci_PUSH_APPLY_PPP []-  PUSH_APPLY_PPPP          -> emit bci_PUSH_APPLY_PPPP []-  PUSH_APPLY_PPPPP         -> emit bci_PUSH_APPLY_PPPPP []-  PUSH_APPLY_PPPPPP        -> emit bci_PUSH_APPLY_PPPPPP []+  PUSH_APPLY_N             -> emit_ bci_PUSH_APPLY_N []+  PUSH_APPLY_V             -> emit_ bci_PUSH_APPLY_V []+  PUSH_APPLY_F             -> emit_ bci_PUSH_APPLY_F []+  PUSH_APPLY_D             -> emit_ bci_PUSH_APPLY_D []+  PUSH_APPLY_L             -> emit_ bci_PUSH_APPLY_L []+  PUSH_APPLY_P             -> emit_ bci_PUSH_APPLY_P []+  PUSH_APPLY_PP            -> emit_ bci_PUSH_APPLY_PP []+  PUSH_APPLY_PPP           -> emit_ bci_PUSH_APPLY_PPP []+  PUSH_APPLY_PPPP          -> emit_ bci_PUSH_APPLY_PPPP []+  PUSH_APPLY_PPPPP         -> emit_ bci_PUSH_APPLY_PPPPP []+  PUSH_APPLY_PPPPPP        -> emit_ bci_PUSH_APPLY_PPPPPP [] -  SLIDE     n by           -> emit bci_SLIDE [wOp n, wOp by]-  ALLOC_AP  n              -> emit bci_ALLOC_AP [truncHalfWord platform n]-  ALLOC_AP_NOUPD n         -> emit bci_ALLOC_AP_NOUPD [truncHalfWord platform n]-  ALLOC_PAP arity n        -> emit bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]-  MKAP      off sz         -> emit bci_MKAP [wOp off, truncHalfWord platform sz]-  MKPAP     off sz         -> emit bci_MKPAP [wOp off, truncHalfWord platform sz]-  UNPACK    n              -> emit bci_UNPACK [wOp n]-  PACK      dcon sz        -> do itbl_no <- lit [BCONPtrItbl (getName dcon)]-                                 emit bci_PACK [Op itbl_no, wOp sz]+  SLIDE     n by           -> emit_ bci_SLIDE [wOp n, wOp by]+  ALLOC_AP  n              -> emit_ bci_ALLOC_AP [truncHalfWord platform n]+  ALLOC_AP_NOUPD n         -> emit_ bci_ALLOC_AP_NOUPD [truncHalfWord platform n]+  ALLOC_PAP arity n        -> emit_ bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]+  MKAP      off sz         -> emit_ bci_MKAP [wOp off, truncHalfWord platform sz]+  MKPAP     off sz         -> emit_ bci_MKPAP [wOp off, truncHalfWord platform sz]+  UNPACK    n              -> emit_ bci_UNPACK [wOp n]+  PACK      dcon sz        -> do itbl_no <- lit1 (BCONPtrItbl (getName dcon))+                                 emit_ bci_PACK [Op itbl_no, wOp sz]   LABEL     lbl            -> label lbl   TESTLT_I  i l            -> do np <- int i-                                 emit bci_TESTLT_I [Op np, LabelOp l]+                                 emit_ bci_TESTLT_I [Op np, LabelOp l]   TESTEQ_I  i l            -> do np <- int i-                                 emit bci_TESTEQ_I [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_I [Op np, LabelOp l]   TESTLT_W  w l            -> do np <- word w-                                 emit bci_TESTLT_W [Op np, LabelOp l]+                                 emit_ bci_TESTLT_W [Op np, LabelOp l]   TESTEQ_W  w l            -> do np <- word w-                                 emit bci_TESTEQ_W [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_W [Op np, LabelOp l]   TESTLT_I64  i l          -> do np <- word64 (fromIntegral i)-                                 emit bci_TESTLT_I64 [Op np, LabelOp l]+                                 emit_ bci_TESTLT_I64 [Op np, LabelOp l]   TESTEQ_I64  i l          -> do np <- word64 (fromIntegral i)-                                 emit bci_TESTEQ_I64 [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_I64 [Op np, LabelOp l]   TESTLT_I32  i l          -> do np <- word (fromIntegral i)-                                 emit bci_TESTLT_I32 [Op np, LabelOp l]+                                 emit_ bci_TESTLT_I32 [Op np, LabelOp l]   TESTEQ_I32 i l           -> do np <- word (fromIntegral i)-                                 emit bci_TESTEQ_I32 [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_I32 [Op np, LabelOp l]   TESTLT_I16  i l          -> do np <- word (fromIntegral i)-                                 emit bci_TESTLT_I16 [Op np, LabelOp l]+                                 emit_ bci_TESTLT_I16 [Op np, LabelOp l]   TESTEQ_I16 i l           -> do np <- word (fromIntegral i)-                                 emit bci_TESTEQ_I16 [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_I16 [Op np, LabelOp l]   TESTLT_I8  i l           -> do np <- word (fromIntegral i)-                                 emit bci_TESTLT_I8 [Op np, LabelOp l]+                                 emit_ bci_TESTLT_I8 [Op np, LabelOp l]   TESTEQ_I8 i l            -> do np <- word (fromIntegral i)-                                 emit bci_TESTEQ_I8 [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_I8 [Op np, LabelOp l]   TESTLT_W64  w l          -> do np <- word64 w-                                 emit bci_TESTLT_W64 [Op np, LabelOp l]+                                 emit_ bci_TESTLT_W64 [Op np, LabelOp l]   TESTEQ_W64  w l          -> do np <- word64 w-                                 emit bci_TESTEQ_W64 [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_W64 [Op np, LabelOp l]   TESTLT_W32  w l          -> do np <- word (fromIntegral w)-                                 emit bci_TESTLT_W32 [Op np, LabelOp l]+                                 emit_ bci_TESTLT_W32 [Op np, LabelOp l]   TESTEQ_W32  w l          -> do np <- word (fromIntegral w)-                                 emit bci_TESTEQ_W32 [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_W32 [Op np, LabelOp l]   TESTLT_W16  w l          -> do np <- word (fromIntegral w)-                                 emit bci_TESTLT_W16 [Op np, LabelOp l]+                                 emit_ bci_TESTLT_W16 [Op np, LabelOp l]   TESTEQ_W16  w l          -> do np <- word (fromIntegral w)-                                 emit bci_TESTEQ_W16 [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_W16 [Op np, LabelOp l]   TESTLT_W8  w l           -> do np <- word (fromIntegral w)-                                 emit bci_TESTLT_W8 [Op np, LabelOp l]+                                 emit_ bci_TESTLT_W8 [Op np, LabelOp l]   TESTEQ_W8  w l           -> do np <- word (fromIntegral w)-                                 emit bci_TESTEQ_W8 [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_W8 [Op np, LabelOp l]   TESTLT_F  f l            -> do np <- float f-                                 emit bci_TESTLT_F [Op np, LabelOp l]+                                 emit_ bci_TESTLT_F [Op np, LabelOp l]   TESTEQ_F  f l            -> do np <- float f-                                 emit bci_TESTEQ_F [Op np, LabelOp l]+                                 emit_ bci_TESTEQ_F [Op np, LabelOp l]   TESTLT_D  d l            -> do np <- double d-                                 emit bci_TESTLT_D [Op np, LabelOp l]+                                 emit_ bci_TESTLT_D [Op np, LabelOp l]   TESTEQ_D  d l            -> do np <- double d-                                 emit bci_TESTEQ_D [Op np, LabelOp l]-  TESTLT_P  i l            -> emit bci_TESTLT_P [SmallOp i, LabelOp l]-  TESTEQ_P  i l            -> emit bci_TESTEQ_P [SmallOp i, LabelOp l]-  CASEFAIL                 -> emit bci_CASEFAIL []-  SWIZZLE   stkoff n       -> emit bci_SWIZZLE [wOp stkoff, IOp n]-  JMP       l              -> emit bci_JMP [LabelOp l]-  ENTER                    -> emit bci_ENTER []-  RETURN rep               -> emit (return_non_tuple rep) []-  RETURN_TUPLE             -> emit bci_RETURN_T []-  CCALL off m_addr i       -> do np <- addr m_addr-                                 emit bci_CCALL [wOp off, Op np, SmallOp i]-  PRIMCALL                 -> emit bci_PRIMCALL []-  BRK_FUN arr tick_mod tickx info_mod infox cc ->-                              do p1 <- ptr (BCOPtrBreakArray arr)-                                 tick_addr <- addr tick_mod-                                 info_addr <- addr info_mod-                                 np <- addr cc-                                 emit bci_BRK_FUN [ Op p1-                                                  , Op tick_addr, Op info_addr-                                                  , SmallOp tickx, SmallOp infox-                                                  , Op np-                                                  ]+                                 emit_ bci_TESTEQ_D [Op np, LabelOp l]+  TESTLT_P  i l            -> emit_ bci_TESTLT_P [SmallOp i, LabelOp l]+  TESTEQ_P  i l            -> emit_ bci_TESTEQ_P [SmallOp i, LabelOp l]+  CASEFAIL                 -> emit_ bci_CASEFAIL []+  SWIZZLE   stkoff n       -> emit_ bci_SWIZZLE [wOp stkoff, IOp n]+  JMP       l              -> emit_ bci_JMP [LabelOp l]+  ENTER                    -> emit_ bci_ENTER []+  RETURN rep               -> emit_ (return_non_tuple rep) []+  RETURN_TUPLE             -> emit_ bci_RETURN_T []+  CCALL off ffi i          -> do np <- lit1 $ BCONPtrFFIInfo ffi+                                 emit_ bci_CCALL [wOp off, Op np, SmallOp i]+  PRIMCALL                 -> emit_ bci_PRIMCALL [] +  OP_ADD w -> case w of+    W64                   -> emit_ bci_OP_ADD_64 []+    W32                   -> emit_ bci_OP_ADD_32 []+    W16                   -> emit_ bci_OP_ADD_16 []+    W8                    -> emit_ bci_OP_ADD_08 []+    _                     -> unsupported_width+  OP_SUB w -> case w of+    W64                   -> emit_ bci_OP_SUB_64 []+    W32                   -> emit_ bci_OP_SUB_32 []+    W16                   -> emit_ bci_OP_SUB_16 []+    W8                    -> emit_ bci_OP_SUB_08 []+    _                     -> unsupported_width+  OP_AND w -> case w of+    W64                   -> emit_ bci_OP_AND_64 []+    W32                   -> emit_ bci_OP_AND_32 []+    W16                   -> emit_ bci_OP_AND_16 []+    W8                    -> emit_ bci_OP_AND_08 []+    _                     -> unsupported_width+  OP_XOR w -> case w of+    W64                   -> emit_ bci_OP_XOR_64 []+    W32                   -> emit_ bci_OP_XOR_32 []+    W16                   -> emit_ bci_OP_XOR_16 []+    W8                    -> emit_ bci_OP_XOR_08 []+    _                     -> unsupported_width+  OP_OR w -> case w of+    W64                    -> emit_ bci_OP_OR_64 []+    W32                    -> emit_ bci_OP_OR_32 []+    W16                    -> emit_ bci_OP_OR_16 []+    W8                     -> emit_ bci_OP_OR_08 []+    _                      -> unsupported_width+  OP_NOT w -> case w of+    W64                   -> emit_ bci_OP_NOT_64 []+    W32                   -> emit_ bci_OP_NOT_32 []+    W16                   -> emit_ bci_OP_NOT_16 []+    W8                    -> emit_ bci_OP_NOT_08 []+    _                     -> unsupported_width+  OP_NEG w -> case w of+    W64                   -> emit_ bci_OP_NEG_64 []+    W32                   -> emit_ bci_OP_NEG_32 []+    W16                   -> emit_ bci_OP_NEG_16 []+    W8                    -> emit_ bci_OP_NEG_08 []+    _                     -> unsupported_width+  OP_MUL w -> case w of+    W64                   -> emit_ bci_OP_MUL_64 []+    W32                   -> emit_ bci_OP_MUL_32 []+    W16                   -> emit_ bci_OP_MUL_16 []+    W8                    -> emit_ bci_OP_MUL_08 []+    _                     -> unsupported_width+  OP_SHL w -> case w of+    W64                   -> emit_ bci_OP_SHL_64 []+    W32                   -> emit_ bci_OP_SHL_32 []+    W16                   -> emit_ bci_OP_SHL_16 []+    W8                    -> emit_ bci_OP_SHL_08 []+    _                     -> unsupported_width+  OP_ASR w -> case w of+    W64                   -> emit_ bci_OP_ASR_64 []+    W32                   -> emit_ bci_OP_ASR_32 []+    W16                   -> emit_ bci_OP_ASR_16 []+    W8                    -> emit_ bci_OP_ASR_08 []+    _                     -> unsupported_width+  OP_LSR w -> case w of+    W64                   -> emit_ bci_OP_LSR_64 []+    W32                   -> emit_ bci_OP_LSR_32 []+    W16                   -> emit_ bci_OP_LSR_16 []+    W8                    -> emit_ bci_OP_LSR_08 []+    _                     -> unsupported_width++  OP_NEQ w -> case w of+    W64                   -> emit_ bci_OP_NEQ_64 []+    W32                   -> emit_ bci_OP_NEQ_32 []+    W16                   -> emit_ bci_OP_NEQ_16 []+    W8                    -> emit_ bci_OP_NEQ_08 []+    _                     -> unsupported_width+  OP_EQ w -> case w of+    W64                    -> emit_ bci_OP_EQ_64 []+    W32                    -> emit_ bci_OP_EQ_32 []+    W16                    -> emit_ bci_OP_EQ_16 []+    W8                     -> emit_ bci_OP_EQ_08 []+    _                      -> unsupported_width++  OP_U_LT w -> case w of+    W64                  -> emit_ bci_OP_U_LT_64 []+    W32                  -> emit_ bci_OP_U_LT_32 []+    W16                  -> emit_ bci_OP_U_LT_16 []+    W8                   -> emit_ bci_OP_U_LT_08 []+    _                    -> unsupported_width+  OP_S_LT w -> case w of+    W64                  -> emit_ bci_OP_S_LT_64 []+    W32                  -> emit_ bci_OP_S_LT_32 []+    W16                  -> emit_ bci_OP_S_LT_16 []+    W8                   -> emit_ bci_OP_S_LT_08 []+    _                    -> unsupported_width+  OP_U_GE w -> case w of+    W64                  -> emit_ bci_OP_U_GE_64 []+    W32                  -> emit_ bci_OP_U_GE_32 []+    W16                  -> emit_ bci_OP_U_GE_16 []+    W8                   -> emit_ bci_OP_U_GE_08 []+    _                    -> unsupported_width+  OP_S_GE w -> case w of+    W64                  -> emit_ bci_OP_S_GE_64 []+    W32                  -> emit_ bci_OP_S_GE_32 []+    W16                  -> emit_ bci_OP_S_GE_16 []+    W8                   -> emit_ bci_OP_S_GE_08 []+    _                    -> unsupported_width+  OP_U_GT w -> case w of+    W64                  -> emit_ bci_OP_U_GT_64 []+    W32                  -> emit_ bci_OP_U_GT_32 []+    W16                  -> emit_ bci_OP_U_GT_16 []+    W8                   -> emit_ bci_OP_U_GT_08 []+    _                    -> unsupported_width+  OP_S_GT w -> case w of+    W64                  -> emit_ bci_OP_S_GT_64 []+    W32                  -> emit_ bci_OP_S_GT_32 []+    W16                  -> emit_ bci_OP_S_GT_16 []+    W8                   -> emit_ bci_OP_S_GT_08 []+    _                    -> unsupported_width+  OP_U_LE w -> case w of+    W64                  -> emit_ bci_OP_U_LE_64 []+    W32                  -> emit_ bci_OP_U_LE_32 []+    W16                  -> emit_ bci_OP_U_LE_16 []+    W8                   -> emit_ bci_OP_U_LE_08 []+    _                    -> unsupported_width+  OP_S_LE w -> case w of+    W64                  -> emit_ bci_OP_S_LE_64 []+    W32                  -> emit_ bci_OP_S_LE_32 []+    W16                  -> emit_ bci_OP_S_LE_16 []+    W8                   -> emit_ bci_OP_S_LE_08 []+    _                    -> unsupported_width++  OP_INDEX_ADDR w -> case w of+    W64                  -> emit_ bci_OP_INDEX_ADDR_64 []+    W32                  -> emit_ bci_OP_INDEX_ADDR_32 []+    W16                  -> emit_ bci_OP_INDEX_ADDR_16 []+    W8                   -> emit_ bci_OP_INDEX_ADDR_08 []+    _                    -> unsupported_width++  BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do+    p1 <- ptr $ BCOPtrBreakArray info_mod+    let -- cast that checks that round-tripping through Word32 doesn't change the value+        infoW32 = let r = fromIntegral infox :: Word32+                   in if fromIntegral r == infox+                    then r+                    else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr infox)+        ix_hi = fromIntegral (infoW32 `shiftR` 16)+        ix_lo = fromIntegral (infoW32 .&. 0xffff)+    info_addr        <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod+    info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS     $ moduleUnitId info_mod+    np               <- lit1 $ BCONPtrCostCentre ibi+    emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr+                      , SmallOp ix_hi, SmallOp ix_lo, Op np ]++#if MIN_VERSION_rts(1,0,3)+  BCO_NAME name            -> do np <- lit1 (BCONPtrStr name)+                                 emit_ bci_BCO_NAME [Op np]+#endif+++   where+    unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width"+    emit_ = emit word_size++    literal :: Literal -> m Word     literal (LitLabel fs _)   = litlabel fs     literal LitNullAddr       = word 0     literal (LitFloat r)      = float (fromRational r)     literal (LitDouble r)     = double (fromRational r)     literal (LitChar c)       = int (ord c)-    literal (LitString bs)    = lit [BCONPtrStr bs]+    literal (LitString bs)    = lit1 (BCONPtrStr bs)        -- LitString requires a zero-terminator when emitted     literal (LitNumber nt i) = case nt of       LitNumInt     -> word (fromIntegral i)@@ -554,10 +893,10 @@     -- analysis messed up.     literal (LitRubbish {}) = word 0 -    litlabel fs = lit [BCONPtrLbl fs]-    addr (RemotePtr a) = words [fromIntegral a]-    words ws = lit (map BCONPtrWord ws)-    word w = words [w]+    litlabel fs = lit1 (BCONPtrLbl fs)+    words ws = lit (fmap BCONPtrWord ws)+    word w = words (OnlyOne w)+    word2 w1 w2 = words (OnlyTwo w1 w2)     word_size  = platformWordSize platform     word_size_bits = platformWordSizeInBits platform @@ -568,36 +907,36 @@     -- Note that we only support host endianness == target endianness for now,     -- even with the external interpreter. This would need to be fixed to     -- support host endianness /= target endianness-    int :: Int -> Assembler Word+    int :: Int -> m Word     int  i = word (fromIntegral i) -    float :: Float -> Assembler Word+    float :: Float -> m Word     float f = word32 (castFloatToWord32 f) -    double :: Double -> Assembler Word+    double :: Double -> m Word     double d = word64 (castDoubleToWord64 d) -    word64 :: Word64 -> Assembler Word+    word64 :: Word64 -> m Word     word64 ww = case word_size of        PW4 ->         let !wl = fromIntegral ww             !wh = fromIntegral (ww `unsafeShiftR` 32)         in case platformByteOrder platform of-            LittleEndian -> words [wl,wh]-            BigEndian    -> words [wh,wl]+            LittleEndian -> word2 wl wh+            BigEndian    -> word2 wh wl        PW8 -> word (fromIntegral ww) -    word8 :: Word8 -> Assembler Word+    word8 :: Word8 -> m Word     word8  x = case platformByteOrder platform of       LittleEndian -> word (fromIntegral x)       BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8)) -    word16 :: Word16 -> Assembler Word+    word16 :: Word16 -> m Word     word16 x = case platformByteOrder platform of       LittleEndian -> word (fromIntegral x)       BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16)) -    word32 :: Word32 -> Assembler Word+    word32 :: Word32 -> m Word     word32 x = case platformByteOrder platform of       LittleEndian -> word (fromIntegral x)       BigEndian    -> case word_size of
compiler/GHC/ByteCode/InfoTable.hs view
@@ -13,15 +13,13 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.ByteCode.Types-import GHC.Runtime.Interpreter+import GHCi.Message  import GHC.Types.Name       ( Name, getName )-import GHC.Types.Name.Env import GHC.Types.RepType  import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity )-import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )+import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isBoxedDataTyCon, tyConDataCons ) import GHC.Core.Multiplicity     ( scaledThing )  import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )@@ -35,33 +33,38 @@ -}  -- Make info tables for the data decls in this module-mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv-mkITbls interp profile tcs =-  foldr plusNameEnv emptyNameEnv <$>-    mapM mkITbl (filter isDataTyCon tcs)+mkITbls :: Profile -> [TyCon] -> [(Name, ConInfoTable)]+mkITbls profile tcs = concatMap mkITbl (filter isBoxedDataTyCon tcs)  where-  mkITbl :: TyCon -> IO ItblEnv+  mkITbl :: TyCon -> [(Name, ConInfoTable)]   mkITbl tc     | dcs `lengthIs` n -- paranoia; this is an assertion.-    = make_constr_itbls interp profile dcs+    = make_constr_itbls profile dcs        where           dcs = tyConDataCons tc           n   = tyConFamilySize tc   mkITbl _ = panic "mkITbl" -mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv-mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]- -- Assumes constructors are numbered from zero, not one-make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv-make_constr_itbls interp profile cons =+make_constr_itbls :: Profile -> [DataCon] -> [(Name, ConInfoTable)]+make_constr_itbls profile cons =   -- TODO: the profile should be bundled with the interpreter: the rts ways are   -- fixed for an interpreter-  mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])- where-  mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)-  mk_itbl dcon conNo = do-     let rep_args = [ prim_rep+  map (uncurry mk_itbl) (zip cons [0..])+  where+    mk_itbl :: DataCon -> Int -> (Name, ConInfoTable)+    mk_itbl dcon conNo =+      ( getName dcon,+        ConInfoTable+          tables_next_to_code+          ptrs'+          nptrs_really+          conNo+          (tagForCon platform dcon)+          descr+      )+      where+         rep_args = [ prim_rep                     | arg <- dataConRepArgTys dcon                     , prim_rep <- typePrimRep (scaledThing arg) ] @@ -79,7 +82,3 @@          platform = profilePlatform profile          constants = platformConstants platform          tables_next_to_code = platformTablesNextToCode platform--     r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really-                              conNo (tagForCon platform dcon) descr)-     return (getName dcon, ItblPtr r)
compiler/GHC/ByteCode/Instr.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-}@@ -14,12 +14,12 @@ import GHC.Prelude  import GHC.ByteCode.Types-import GHCi.RemoteTypes-import GHCi.FFI (C_ffi_cif)+import GHC.Cmm.Type (Width) import GHC.StgToCmm.Layout     ( ArgRep(..) ) import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Literal+import GHC.Types.Unique import GHC.Core.DataCon import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout ( StgWord )@@ -27,11 +27,12 @@ import Data.Int import Data.Word -import GHC.Stack.CCS (CostCentre)+#if MIN_VERSION_rts(1,0,3)+import Data.ByteString (ByteString)+#endif + import GHC.Stg.Syntax-import GHCi.BreakArray (BreakArray)-import Language.Haskell.Syntax.Module.Name (ModuleName)  -- ---------------------------------------------------------------------------- -- Bytecode instructions@@ -45,15 +46,17 @@         protoBCOBitmapSize :: Word,         protoBCOArity      :: Int,         -- what the BCO came from, for debugging only-        protoBCOExpr       :: Either [CgStgAlt] CgStgRhs,-        -- malloc'd pointers-        protoBCOFFIs       :: [FFIInfo]+        protoBCOExpr       :: Either [CgStgAlt] CgStgRhs    }  -- | A local block label (e.g. identifying a case alternative). newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 }   deriving (Eq, Ord) +-- Just so we can easily juse UniqFM.+instance Uniquable LocalLabel where+  getUnique (LocalLabel w) = mkUniqueGrimily $ fromIntegral w+ instance Outputable LocalLabel where   ppr (LocalLabel lbl) = text "lbl:" <> ppr lbl @@ -186,7 +189,12 @@    -- The Word16 value is a constructor number and therefore    -- stored in the insn stream rather than as an offset into    -- the literal pool.++   -- | Test whether the tag of a closure pointer is less than the given value.+   -- If not, jump to the given label.    | TESTLT_P  !Word16 LocalLabel+   -- | Test whether the tag of a closure pointer is equal to the given value.+   -- If not, jump to the given label.    | TESTEQ_P  !Word16 LocalLabel     | CASEFAIL@@ -194,7 +202,7 @@     -- For doing calls to C (via glue code generated by libffi)    | CCALL            !WordOff  -- stack frame size-                      (RemotePtr C_ffi_cif) -- addr of the glue code+                      !FFIInfo  -- libffi ffi_cif function prototype                       !Word16   -- flags.                                 --                                 -- 0x1: call is interruptible@@ -205,6 +213,39 @@     | PRIMCALL +   -- Primops - The actual interpreter instructions are flattened into 64/32/16/8 wide+   -- instructions. But for generating code it's handy to have the width as argument+   -- to avoid duplication.+   | OP_ADD !Width+   | OP_SUB !Width+   | OP_AND !Width+   | OP_XOR !Width+   | OP_MUL !Width+   | OP_SHL !Width+   | OP_ASR !Width+   | OP_LSR !Width+   | OP_OR  !Width++   | OP_NOT !Width+   | OP_NEG !Width++   | OP_NEQ !Width+   | OP_EQ !Width++   | OP_U_LT !Width+   | OP_U_GE !Width+   | OP_U_GT !Width+   | OP_U_LE !Width++   | OP_S_LT !Width+   | OP_S_GE !Width+   | OP_S_GT !Width+   | OP_S_LE !Width++   -- Always puts at least a machine word on the stack.+   -- We zero extend the result we put on the stack according to host byte order.+   | OP_INDEX_ADDR !Width+    -- For doing magic ByteArray passing to foreign calls    | SWIZZLE          !WordOff -- to the ptr N words down the stack,                       !Int     -- add M@@ -217,13 +258,24 @@                    -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode     -- Breakpoints-   | BRK_FUN          (ForeignRef BreakArray)-                      (RemotePtr ModuleName) -- breakpoint tick module-                      !Word16                -- breakpoint tick index-                      (RemotePtr ModuleName) -- breakpoint info module-                      !Word16                -- breakpoint info index-                      (RemotePtr CostCentre)+   | BRK_FUN          !InternalBreakpointId +#if MIN_VERSION_rts(1,0,3)+   -- | A "meta"-instruction for recording the name of a BCO for debugging purposes.+   -- These are ignored by the interpreter but helpfully printed by the disassmbler.+   | BCO_NAME         !ByteString+#endif+++{- Note [BCO_NAME]+   ~~~~~~~~~~~~~~~+   The BCO_NAME instruction is a debugging-aid enabled with the -fadd-bco-name flag.+   When enabled the bytecode assembler will prepend a BCO_NAME instruction to every+   generated bytecode object capturing the STG name of the binding the BCO implements.+   This is then printed by the bytecode disassembler, allowing bytecode objects to be+   readily correlated with their STG and Core source.+ -}+ -- ----------------------------------------------------------------------------- -- Printing bytecode instructions @@ -233,10 +285,9 @@                  , protoBCOBitmap     = bitmap                  , protoBCOBitmapSize = bsize                  , protoBCOArity      = arity-                 , protoBCOExpr       = origin-                 , protoBCOFFIs       = ffis })+                 , protoBCOExpr       = origin })       = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity-                <+> text (show ffis) <> colon)+                <> colon)         $$ nest 3 (case origin of                       Left alts ->                         vcat (zipWith (<+>) (char '{' : repeat (char ';'))@@ -360,24 +411,52 @@    ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab    ppr CASEFAIL              = text "CASEFAIL"    ppr (JMP lab)             = text "JMP"      <+> ppr lab-   ppr (CCALL off marshal_addr flags) = text "CCALL   " <+> ppr off+   ppr (CCALL off ffi flags) = text "CCALL   " <+> ppr off                                                 <+> text "marshal code at"-                                               <+> text (show marshal_addr)+                                               <+> text (show ffi)                                                <+> (case flags of                                                       0x1 -> text "(interruptible)"                                                       0x2 -> text "(unsafe)"                                                       _   -> empty)    ppr PRIMCALL              = text "PRIMCALL"++   ppr (OP_ADD w)            = text "OP_ADD_" <> ppr w+   ppr (OP_SUB w)            = text "OP_SUB_" <> ppr w+   ppr (OP_AND w)            = text "OP_AND_" <> ppr w+   ppr (OP_XOR w)            = text "OP_XOR_" <> ppr w+   ppr (OP_OR w)             = text "OP_OR_" <> ppr w+   ppr (OP_NOT w)            = text "OP_NOT_" <> ppr w+   ppr (OP_NEG w)            = text "OP_NEG_" <> ppr w+   ppr (OP_MUL w)            = text "OP_MUL_" <> ppr w+   ppr (OP_SHL w)            = text "OP_SHL_" <> ppr w+   ppr (OP_ASR w)            = text "OP_ASR_" <> ppr w+   ppr (OP_LSR w)            = text "OP_LSR_" <> ppr w++   ppr (OP_EQ w)             = text "OP_EQ_" <> ppr w+   ppr (OP_NEQ w)            = text "OP_NEQ_" <> ppr w+   ppr (OP_S_LT w)           = text "OP_S_LT_" <> ppr w+   ppr (OP_S_GE w)           = text "OP_S_GE_" <> ppr w+   ppr (OP_S_GT w)           = text "OP_S_GT_" <> ppr w+   ppr (OP_S_LE w)           = text "OP_S_LE_" <> ppr w+   ppr (OP_U_LT w)           = text "OP_U_LT_" <> ppr w+   ppr (OP_U_GE w)           = text "OP_U_GE_" <> ppr w+   ppr (OP_U_GT w)           = text "OP_U_GT_" <> ppr w+   ppr (OP_U_LE w)           = text "OP_U_LE_" <> ppr w++   ppr (OP_INDEX_ADDR w)     = text "OP_INDEX_ADDR_" <> ppr w+    ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff                                                <+> text "by" <+> ppr n    ppr ENTER                 = text "ENTER"    ppr (RETURN pk)           = text "RETURN  " <+> ppr pk    ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"-   ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)+   ppr (BRK_FUN (InternalBreakpointId info_mod infox))                              = text "BRK_FUN" <+> text "<breakarray>"-                               <+> text "<tick_module>" <+> ppr tickx-                               <+> text "<info_module>" <+> ppr infox+                               <+> ppr info_mod <+> ppr infox                                <+> text "<cc>"+#if MIN_VERSION_rts(1,0,3)+   ppr (BCO_NAME nm)         = text "BCO_NAME" <+> text (show nm)+#endif   @@ -473,6 +552,31 @@ bciStackUse RETURN_TUPLE{}        = 1 -- pushes stg_ret_t header bciStackUse CCALL{}               = 0 bciStackUse PRIMCALL{}            = 1 -- pushes stg_primcall+bciStackUse OP_ADD{}              = 0 -- We overestimate, it's -1 actually ...+bciStackUse OP_SUB{}              = 0+bciStackUse OP_AND{}              = 0+bciStackUse OP_XOR{}              = 0+bciStackUse OP_OR{}               = 0+bciStackUse OP_NOT{}              = 0+bciStackUse OP_NEG{}              = 0+bciStackUse OP_MUL{}              = 0+bciStackUse OP_SHL{}              = 0+bciStackUse OP_ASR{}              = 0+bciStackUse OP_LSR{}              = 0++bciStackUse OP_NEQ{}              = 0+bciStackUse OP_EQ{}               = 0+bciStackUse OP_S_LT{}               = 0+bciStackUse OP_S_GT{}               = 0+bciStackUse OP_S_LE{}               = 0+bciStackUse OP_S_GE{}               = 0+bciStackUse OP_U_LT{}               = 0+bciStackUse OP_U_GT{}               = 0+bciStackUse OP_U_LE{}               = 0+bciStackUse OP_U_GE{}               = 0++bciStackUse OP_INDEX_ADDR{}         = 0+ bciStackUse SWIZZLE{}             = 0 bciStackUse BRK_FUN{}             = 0 @@ -482,3 +586,6 @@ bciStackUse MKAP{}                = 0 bciStackUse MKPAP{}               = 0 bciStackUse PACK{}                = 1 -- worst case is PACK 0 words+#if MIN_VERSION_rts(1,0,3)+bciStackUse BCO_NAME{}            = 0+#endif
compiler/GHC/ByteCode/Linker.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MagicHash             #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE RecordWildCards       #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- --  (c) The University of Glasgow 2002-2006@@ -11,7 +14,6 @@   ( linkBCO   , lookupStaticPtr   , lookupIE-  , nameToCLabel   , linkFail   ) where@@ -25,11 +27,12 @@  import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids-import GHC.Builtin.Names +import GHC.Unit.Module.Env import GHC.Unit.Types  import GHC.Data.FastString+import GHC.Data.Maybe import GHC.Data.SizedSeq  import GHC.Linker.Types@@ -42,8 +45,6 @@ import qualified GHC.Types.Id as Id import GHC.Types.Unique.DFM -import Language.Haskell.Syntax.Module.Name- -- Standard libraries import Data.Array.Unboxed import Foreign.Ptr@@ -57,24 +58,27 @@   :: Interp   -> PkgsLoaded   -> LinkerEnv+  -> LinkedBreaks   -> NameEnv Int   -> UnlinkedBCO   -> IO ResolvedBCO-linkBCO interp pkgs_loaded le bco_ix+linkBCO interp pkgs_loaded le lb bco_ix            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do   -- fromIntegral Word -> Word64 should be a no op if Word is Word64   -- otherwise it will result in a cast to longlong on 32bit systems.-  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0)-  ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0)+  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0)+  ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0)   let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits-  return (ResolvedBCO isLittleEndian arity-              insns-              bitmap-              (mkBCOByteArray lits')-              (addListToSS emptySS ptrs))+  return $ ResolvedBCO { resolvedBCOIsLE   = isLittleEndian+                       , resolvedBCOArity  = arity+                       , resolvedBCOInstrs = insns+                       , resolvedBCOBitmap = bitmap+                       , resolvedBCOLits   = mkBCOByteArray lits'+                       , resolvedBCOPtrs   = addListToSS emptySS ptrs+                       } -lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word-lookupLiteral interp pkgs_loaded le ptr = case ptr of+lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word+lookupLiteral interp pkgs_loaded le lb ptr = case ptr of   BCONPtrWord lit -> return lit   BCONPtrLbl  sym -> do     Ptr a# <- lookupStaticPtr interp sym@@ -85,36 +89,49 @@   BCONPtrAddr nm -> do     Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm     return (W# (int2Word# (addr2Int# a#)))-  BCONPtrStr _ ->-    -- should be eliminated during assembleBCOs-    panic "lookupLiteral: BCONPtrStr"+  BCONPtrStr bs -> do+    RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs]+    pure $ fromIntegral p+  BCONPtrFS fs -> do+    RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bytesFS fs]+    pure $ fromIntegral p+  BCONPtrFFIInfo (FFIInfo {..}) -> do+    RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet+    pure $ fromIntegral p+  BCONPtrCostCentre InternalBreakpointId{..}+    | interpreterProfiled interp -> do+        case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of+          RemotePtr p -> pure $ fromIntegral p+    | otherwise ->+        case toRemotePtr nullPtr of+          RemotePtr p -> pure $ fromIntegral p  lookupStaticPtr :: Interp -> FastString -> IO (Ptr ()) lookupStaticPtr interp addr_of_label_string = do-  m <- lookupSymbol interp addr_of_label_string+  m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string)   case m of     Just ptr -> return ptr     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"-                  (unpackFS addr_of_label_string)+                  (ppr addr_of_label_string)  lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ()) lookupIE interp pkgs_loaded ie con_nm =   case lookupNameEnv ie con_nm of     Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))     Nothing -> do -- try looking up in the object files.-       let sym_to_find1 = nameToCLabel con_nm "con_info"-       m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info"+       let sym_to_find1 = IConInfoSymbol con_nm+       m <- lookupHsSymbol interp pkgs_loaded sym_to_find1        case m of           Just addr -> return addr           Nothing              -> do -- perhaps a nullary constructor?-                   let sym_to_find2 = nameToCLabel con_nm "static_info"-                   n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info"+                   let sym_to_find2 = IStaticInfoSymbol con_nm+                   n <- lookupHsSymbol interp pkgs_loaded sym_to_find2                    case n of                       Just addr -> return addr                       Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"-                                      (unpackFS sym_to_find1 ++ " or " ++-                                       unpackFS sym_to_find2)+                                      (ppr sym_to_find1 <> " or " <>+                                       ppr sym_to_find2)  -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())@@ -122,30 +139,31 @@   case lookupNameEnv ae addr_nm of     Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)     Nothing -> do -- try looking up in the object files.-      let sym_to_find = nameToCLabel addr_nm "bytes"+      let sym_to_find = IBytesSymbol addr_nm                           -- see Note [Bytes label] in GHC.Cmm.CLabel-      m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes"+      m <- lookupHsSymbol interp pkgs_loaded sym_to_find       case m of         Just ptr -> return ptr         Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"-                     (unpackFS sym_to_find)+                     (ppr sym_to_find)  lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ()) lookupPrimOp interp pkgs_loaded primop = do   let sym_to_find = primopToCLabel primop "closure"-  m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure"+  m <- lookupHsSymbol interp pkgs_loaded (IClosureSymbol (Id.idName $ primOpId primop))   case m of     Just p -> return (toRemotePtr p)-    Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find+    Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find)  resolvePtr   :: Interp   -> PkgsLoaded   -> LinkerEnv+  -> LinkedBreaks   -> NameEnv Int   -> BCOPtr   -> IO ResolvedBCOPtr-resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of+resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of   BCOPtrName nm     | Just ix <- lookupNameEnv bco_ix nm     -> return (ResolvedBCORef ix) -- ref to another BCO in this group@@ -156,30 +174,30 @@     | otherwise     -> assertPpr (isExternalName nm) (ppr nm) $        do-          let sym_to_find = nameToCLabel nm "closure"-          m <- lookupHsSymbol interp pkgs_loaded nm "closure"+          let sym_to_find = IClosureSymbol nm+          m <- lookupHsSymbol interp pkgs_loaded sym_to_find           case m of             Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))-            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)+            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find)    BCOPtrPrimOp op     -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op    BCOPtrBCO bco-    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco+    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco -  BCOPtrBreakArray breakarray-    -> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba)+  BCOPtrBreakArray tick_mod ->+    withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $+      \ba -> pure $ ResolvedBCOPtrBreakArray ba  -- | Look up the address of a Haskell symbol in the currently -- loaded units. -- -- See Note [Looking up symbols in the relevant objects].-lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))-lookupHsSymbol interp pkgs_loaded nm sym_suffix = do-  massertPpr (isExternalName nm) (ppr nm)-  let sym_to_find = nameToCLabel nm sym_suffix-      pkg_id = moduleUnitId $ nameModule nm+lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (Ptr ()))+lookupHsSymbol interp pkgs_loaded sym_to_find = do+  massertPpr (isExternalName (interpSymbolName sym_to_find)) (ppr sym_to_find)+  let pkg_id = moduleUnitId $ nameModule (interpSymbolName sym_to_find)       loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id        go (dll:dlls) = do@@ -193,12 +211,12 @@    go loaded_dlls -linkFail :: String -> String -> IO a+linkFail :: String -> SDoc -> IO a linkFail who what    = throwGhcExceptionIO (ProgramError $         unlines [ "",who                 , "During interactive linking, GHCi couldn't find the following symbol:"-                , ' ' : ' ' : what+                , ' ' : ' ' : showSDocUnsafe what                 , "This may be due to you not asking GHCi to load extra object files,"                 , "archives or DLLs needed by your current session.  Restart GHCi, specifying"                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"@@ -209,31 +227,14 @@                 ])  -nameToCLabel :: Name -> String -> FastString-nameToCLabel n suffix = mkFastString label-  where-    encodeZ = zString . zEncodeFS-    (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of-        -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers-        -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.-        mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS-        mod -> mod-    packagePart = encodeZ (unitFS pkgKey)-    modulePart  = encodeZ (moduleNameFS modName)-    occPart     = encodeZ $ occNameMangledFS (nameOccName n) -    label = concat-        [ if pkgKey == mainUnit then "" else packagePart ++ "_"-        , modulePart-        , '_':occPart-        , '_':suffix-        ]  + -- See Note [Primop wrappers] in GHC.Builtin.PrimOps primopToCLabel :: PrimOp -> String -> String primopToCLabel primop suffix = concat-    [ "ghczmprim_GHCziPrimopWrappers_"+    [ "ghczminternal_GHCziInternalziPrimopWrappers_"     , zString (zEncodeFS (occNameFS (primOpOcc primop)))     , '_':suffix     ]
compiler/GHC/Cmm/CallConv.hs view
compiler/GHC/Cmm/Config.hs view
@@ -24,8 +24,6 @@   , cmmExternalDynamicRefs :: !Bool    -- ^ Generate code to link against dynamic libraries   , cmmDoCmmSwitchPlans    :: !Bool    -- ^ Should the Cmm pass replace Stg switch statements   , cmmSplitProcPoints     :: !Bool    -- ^ Should Cmm split proc points or not-  , cmmAllowMul2           :: !Bool    -- ^ Does this platform support mul2-  , cmmOptConstDivision    :: !Bool    -- ^ Should we optimize constant divisors   }  -- | retrieve the target Cmm platform
compiler/GHC/Cmm/DebugBlock.hs view
@@ -6,9 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-}---{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE EmptyCase #-}  ----------------------------------------------------------------------------- --@@ -41,22 +39,27 @@ import GHC.Cmm import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse ) import GHC.Cmm.Utils-import GHC.Data.FastString ( nilFS, mkFastString )+import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString ) import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.Tickish-import GHC.Utils.Misc      ( partitionWith, seqList )+import GHC.Utils.Misc      ( seqList )  import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label  import Data.Maybe-import Data.List     ( minimumBy, nubBy )+import Data.List     ( nubBy )+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )+import qualified Data.List.NonEmpty as NE import Data.Ord      ( comparing ) import qualified Data.Map as Map+import Data.Foldable ( toList )+import Data.Either ( partitionEithers )+import Data.Void  -- | Debug information about a block of code. Ticks scope over nested -- blocks.@@ -94,23 +97,32 @@  -- | Intermediate data structure holding debug-relevant context information -- about a block.-type BlockContext = (CmmBlock, RawCmmDecl)+type BlockContext = (CmmBlock, RawCmmDeclNoStatics) +-- Same as `RawCmmDecl`, but statically (in GHC) excludes the possibility of statics (in the CMM+-- code). (The first argument is `Void` rather than `RawCmmStatics`.+type RawCmmDeclNoStatics+   = GenCmmDecl+        Void+        (LabelMap RawCmmStatics)+        CmmGraph+ -- | Extract debug data from a group of procedures. We will prefer -- source notes that come from the given module (presumably the module -- that we are currently compiling).-cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]+cmmDebugGen :: ModLocation -> [RawCmmDecl] -> [DebugBlock] cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes   where-      blockCtxs :: Map.Map CmmTickScope [BlockContext]+      blockCtxs :: Map.Map CmmTickScope (NonEmpty BlockContext)       blockCtxs = blockContexts decls        -- Analyse tick scope structure: Each one is either a top-level       -- tick scope, or the child of another.       (topScopes, childScopes)-        = partitionWith (\a -> findP a a) $ Map.keys blockCtxs+        = partitionEithers $ map (\(k, a) -> findP (k, a) k) $ Map.toList blockCtxs+       findP tsc GlobalScope = Left tsc -- top scope-      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)+      findP tsc scp | Just x <- Map.lookup scp' blockCtxs = Right (scp', tsc, x)                     | otherwise                   = findP tsc scp'         where -- Note that we only following the left parent of               -- combined scopes. This loses us ticks, which we will@@ -118,7 +130,7 @@               scp' | SubScope _ scp' <- scp      = scp'                    | CombinedScope scp' _ <- scp = scp' -      scopeMap = foldl' (\acc (key, scope) -> insertMulti key scope acc) Map.empty childScopes+      scopeMap = foldl' (\ acc (k, (k', a'), _) -> insertMulti k (k', a') acc) Map.empty childScopes        -- This allows us to recover ticks that we lost by flattening       -- the graph. Basically, if the parent is A but the child is@@ -137,7 +149,7 @@                    | SubScope _ s' <- s       = ticks ++ go s'                    | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2                    | otherwise                = panic "ticksToCopy impossible"-                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs+                where ticks = bCtxsTicks $ maybe [] toList $ Map.lookup s blockCtxs       ticksToCopy _ = []       bCtxsTicks = concatMap (blockTicks . fst) @@ -147,21 +159,19 @@       -- (if we generated one, we probably want debug information to       -- refer to it).       bestSrcTick = minimumBy (comparing rangeRating)-      rangeRating (SourceNote span _)+      rangeRating (span, _)         | srcSpanFile span == thisFile = 1         | otherwise                    = 2 :: Int-      rangeRating note                 = pprPanic "rangeRating" (ppr note)       thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc        -- Returns block tree for this scope as well as all nested       -- scopes. Note that if there are multiple blocks in the (exact)       -- same scope we elect one as the "branch" node and add the rest       -- as children.-      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock-      blocksForScope cstick scope = mkBlock True (head bctxs)-        where bctxs = fromJust $ Map.lookup scope blockCtxs-              nested = fromMaybe [] $ Map.lookup scope scopeMap-              childs = map (mkBlock False) (tail bctxs) +++      blocksForScope :: Maybe (RealSrcSpan, LexicalFastString) -> (CmmTickScope, NonEmpty BlockContext) -> DebugBlock+      blocksForScope cstick (scope, bctx:|bctxs) = mkBlock True bctx+        where nested = fromMaybe [] $ Map.lookup scope scopeMap+              childs = map (mkBlock False) bctxs ++                        map (blocksForScope stick) nested                mkBlock :: Bool -> BlockContext -> DebugBlock@@ -173,11 +183,13 @@                              , dblParent       = Nothing                              , dblTicks        = ticks                              , dblPosition     = Nothing -- see cmmDebugLink-                             , dblSourceTick   = stick+                             , dblSourceTick   = uncurry SourceNote <$> stick                              , dblBlocks       = blocks                              , dblUnwind       = []                              }-                where (CmmProc infos _entryLbl _ graph) = prc+                where (infos, graph) = case prc of+                          CmmProc infos _ _ graph -> (infos, graph)+                          CmmData _ v -> case v of                       label = entryLabel block                       info = mapLookup label infos                       blocks | top       = seqList childs childs@@ -185,26 +197,26 @@                -- A source tick scopes over all nested blocks. However               -- their source ticks might take priority.-              isSourceTick SourceNote {} = True-              isSourceTick _             = False+              isSourceTick (SourceNote span a) = Just (span, a)+              isSourceTick _ = Nothing               -- Collect ticks from all blocks inside the tick scope.               -- We attempt to filter out duplicates while we're at it.               ticks = nubBy (flip tickishContains) $                       bCtxsTicks bctxs ++ ticksToCopy scope-              stick = case filter isSourceTick ticks of-                []     -> cstick-                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)+              stick = case nonEmpty $ mapMaybe isSourceTick ticks of+                Nothing -> cstick+                Just sticks -> Just $! bestSrcTick (sticks `NE.appendList` maybeToList cstick)  -- | Build a map of blocks sorted by their tick scopes -- -- This involves a pre-order traversal, as we want blocks in rough -- control flow order (so ticks have a chance to be sorted in the -- right order).-blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]-blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls-  where walkProc :: RawCmmDecl-                 -> Map.Map CmmTickScope [BlockContext]-                 -> Map.Map CmmTickScope [BlockContext]+blockContexts :: [GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph] -> Map.Map CmmTickScope (NonEmpty BlockContext)+blockContexts = Map.map NE.reverse . foldr walkProc Map.empty+  where walkProc :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph+                 -> Map.Map CmmTickScope (NonEmpty BlockContext)+                 -> Map.Map CmmTickScope (NonEmpty BlockContext)         walkProc CmmData{}                 m = m         walkProc prc@(CmmProc _ _ _ graph) m           | mapNull blocks = m@@ -213,26 +225,27 @@                 entry  = [mapFind (g_entry graph) blocks]                 emptyLbls = setEmpty :: LabelSet -        walkBlock :: RawCmmDecl -> [Block CmmNode C C]-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])+        walkBlock :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph -> [Block CmmNode C C]+                  -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext))+                  -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext))         walkBlock _   []             c            = c-        walkBlock prc (block:blocks) (visited, m)-          | lbl `setMember` visited-          = walkBlock prc blocks (visited, m)-          | otherwise-          = walkBlock prc blocks $-            walkBlock prc succs-              (lbl `setInsert` visited,-               insertMulti scope (block, prc) m)+        walkBlock prc (block:blocks) (visited, m) = case (prc, setMember lbl visited) of+            (CmmProc x y z graph, False) ->+                let succs = flip mapFind (toBlockMap graph) <$>+                        successors (lastNode block) in+                walkBlock prc blocks $+                walkBlock prc succs+                  ( lbl `setInsert` visited+                  , insertMultiNE scope (block, CmmProc x y z graph) m )+            _ -> walkBlock prc blocks (visited, m)           where CmmEntry lbl scope = firstNode block-                (CmmProc _ _ _ graph) = prc-                succs = map (flip mapFind (toBlockMap graph))-                            (successors (lastNode block))         mapFind = mapFindWithDefault (error "contextTree: block not found!")  insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a] insertMulti k v = Map.insertWith (const (v:)) k [v]++insertMultiNE :: Ord k => k -> a -> Map.Map k (NonEmpty a) -> Map.Map k (NonEmpty a)+insertMultiNE k v = Map.insertWith (const (v NE.<|)) k (NE.singleton v)  cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label] cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls
compiler/GHC/Cmm/LayoutStack.hs view
@@ -36,6 +36,7 @@ import Control.Monad.Fix import Data.Array as Array import Data.List (nub)+import Data.List.NonEmpty ( NonEmpty (..) )  {- Note [Stack Layout]    ~~~~~~~~~~~~~~~~~~~@@ -346,7 +347,7 @@            this_sp_hwm | isGcJump last0 = 0                        | otherwise      = sp0 - sp_off -           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))+           hwm' = maximum (acc_hwm :| this_sp_hwm : map sm_sp (mapElems out))         go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks) @@ -373,7 +374,7 @@  collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff) collectContInfo blocks-  = (maximum ret_offs, mapFromList (catMaybes mb_argss))+  = (maximum (expectNonEmpty ret_offs), mapFromList (catMaybes mb_argss))  where   (mb_argss, ret_offs) = mapAndUnzip get_cont blocks 
compiler/GHC/Cmm/Lint.hs view
@@ -102,9 +102,11 @@   platform <- getPlatform   tys <- mapM lintCmmExpr args   lintShiftOp op (zip args tys)-  if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op-        then cmmCheckMachOp op args tys-        else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)+  let machop_arg_widths = machOpArgReps platform op+      arg_tys           = map (cmmExprType platform) args+  if map typeWidth arg_tys == machop_arg_widths+    then cmmCheckMachOp op args tys+    else cmmLintMachOpErr expr arg_tys machop_arg_widths lintCmmExpr (CmmRegOff reg offset)   = do let rep = typeWidth (cmmRegType reg)        lintCmmExpr (CmmMachOp (MO_Add rep)@@ -180,14 +182,13 @@             return ()    CmmUnsafeForeignCall target _formals actuals -> do-            lintTarget target             let lintArg expr = do                   -- Arguments can't mention caller-saved                   -- registers. See Note [Register parameter passing].                   mayNotMentionCallerSavedRegs (text "foreign call argument") expr                   lintCmmExpr expr--            mapM_ lintArg actuals+            arg_tys <- mapM lintArg actuals+            lintTarget arg_tys target   lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()@@ -213,7 +214,6 @@           maybe (return ()) checkTarget cont    CmmForeignCall tgt _ args succ _ _ _ -> do-          lintTarget tgt           let lintArg expr = do                 -- Arguments can't mention caller-saved                 -- registers. See Note [Register@@ -223,19 +223,24 @@                 -- places in caller-saved registers.                 mayNotMentionCallerSavedRegs (text "foreign call argument") expr                 lintCmmExpr expr-          mapM_ lintArg args+          arg_tys <- mapM lintArg args+          lintTarget arg_tys tgt           checkTarget succ  where   checkTarget id      | setMember id labels = return ()      | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id) -lintTarget :: ForeignTarget -> CmmLint ()-lintTarget (ForeignTarget e _) = do+lintTarget :: [CmmType] -> ForeignTarget -> CmmLint ()+lintTarget _arg_tys (ForeignTarget e _) = do     mayNotMentionCallerSavedRegs (text "foreign target") e     _ <- lintCmmExpr e     return ()-lintTarget (PrimTarget {})     = return ()+lintTarget arg_tys (PrimTarget mop) = do+  platform <- getPlatform+  let machop_arg_tys = callishMachOpArgTys platform mop+  unless (and $ zipWith cmmCompatType arg_tys machop_arg_tys) $+    cmmLintCallishMachOpErr mop arg_tys machop_arg_tys  -- | As noted in Note [Register parameter passing], the arguments and -- 'ForeignTarget' of a foreign call mustn't mention@@ -285,6 +290,13 @@                    nest 2 (pdoc platform expr) $$                       (text "op is expecting: " <+> ppr opExpectsRep) $$                       (text "arguments provide: " <+> ppr argsRep))++cmmLintCallishMachOpErr :: CallishMachOp -> [CmmType] -> [CmmType] -> CmmLint a+cmmLintCallishMachOpErr mop argTys mopTys+     = cmmLintErr (text "in Callish MachOp application: " $$+                   nest 2 (text $ show mop) $$+                      (text "op is expecting: " <+> ppr mopTys) $$+                      (text "arguments provide: " <+> ppr argTys))  cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a cmmLintAssignErr stmt e_ty r_ty
compiler/GHC/Cmm/Liveness.hs view
@@ -57,7 +57,7 @@   where     entry = g_entry graph     check facts =-        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts+        noLiveOnEntry entry (expectJust $ mapLookup entry facts) facts  cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalRegUse cmmGlobalLiveness platform graph =@@ -120,7 +120,7 @@   where     entry = g_entry graph     check facts =-        noLiveOnEntryL entry (expectJust "check" $ mapLookup entry facts) facts+        noLiveOnEntryL entry (expectJust $ mapLookup entry facts) facts  -- | On entry to the procedure, there had better not be any LocalReg's live-in. noLiveOnEntryL :: BlockId -> LRegSet -> a -> a@@ -154,5 +154,4 @@     let joined = gen_killL platform xNode $! joinOutFacts liveLatticeL xNode fBase         !result = foldNodesBwdOO (gen_killL platform) middle joined     in mapSingleton (entryLabel eNode) result- 
compiler/GHC/Cmm/Opt.hs view
@@ -5,53 +5,29 @@ -- (c) The University of Glasgow 2006 -- ------------------------------------------------------------------------------{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE PatternSynonyms #-} module GHC.Cmm.Opt (         constantFoldNode,         constantFoldExpr,         cmmMachOpFold,-        cmmMachOpFoldM,-        Opt, runOpt+        cmmMachOpFoldM  ) where  import GHC.Prelude -import GHC.Cmm.Dataflow.Block import GHC.Cmm.Utils import GHC.Cmm-import GHC.Cmm.Config-import GHC.Types.Unique.DSM- import GHC.Utils.Misc+ import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Platform  import Data.Maybe import GHC.Float-import Data.Word-import GHC.Exts (oneShot)-import Control.Monad -constantFoldNode :: CmmNode e x -> Opt (CmmNode e x)-constantFoldNode (CmmUnsafeForeignCall (PrimTarget op) res args)-  = traverse constantFoldExprOpt args >>= cmmCallishMachOpFold op res-constantFoldNode node-  = mapExpOpt constantFoldExprOpt node -constantFoldExprOpt :: CmmExpr -> Opt CmmExpr-constantFoldExprOpt e = wrapRecExpOpt f e-  where-    f (CmmMachOp op args)-      = do-        cfg <- getConfig-        case cmmMachOpFold (cmmPlatform cfg) op args of-          CmmMachOp op' args' -> fromMaybe (CmmMachOp op' args') <$> cmmMachOpFoldOptM cfg op' args'-          e -> pure e-    f (CmmRegOff r 0) = pure (CmmReg r)-    f e = pure e+constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x+constantFoldNode platform = mapExp (constantFoldExpr platform)  constantFoldExpr :: Platform -> CmmExpr -> CmmExpr constantFoldExpr platform = wrapRecExp f@@ -198,9 +174,9 @@         MO_S_Lt _ -> Just $! CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth platform))         MO_S_Le _ -> Just $! CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform)) -        MO_Add r -> Just $! CmmLit (CmmInt (x + y) r)-        MO_Sub r -> Just $! CmmLit (CmmInt (x - y) r)-        MO_Mul r -> Just $! CmmLit (CmmInt (x * y) r)+        MO_Add r -> Just $! CmmLit (CmmInt (narrowU r $ x + y) r)+        MO_Sub r -> Just $! CmmLit (CmmInt (narrowS r $ x - y) r)+        MO_Mul r -> Just $! CmmLit (CmmInt (narrowU r $ x * y) r)         MO_U_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `quot` y_u) r)         MO_U_Rem  r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `rem`  y_u) r)         MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `quot` y_s) r)@@ -210,7 +186,7 @@         MO_Or    r -> Just $! CmmLit (CmmInt (x .|. y) r)         MO_Xor   r -> Just $! CmmLit (CmmInt (x `xor` y) r) -        MO_Shl   r -> Just $! CmmLit (CmmInt (x   `shiftL` fromIntegral y) r)+        MO_Shl   r -> Just $! CmmLit (CmmInt (narrowU r $ x   `shiftL` fromIntegral y) r)         MO_U_Shr r -> Just $! CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)         MO_S_Shr r -> Just $! CmmLit (CmmInt (x_s `shiftR` fromIntegral y) r) @@ -354,7 +330,7 @@     maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)     maybe_comparison _ _ _ = Nothing --- We can often do something with constants of 0, 1 and (-1) ...+-- We can often do something with constants of 0 and 1 ... -- See Note [Comparison operators]  cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))]@@ -425,8 +401,6 @@         MO_Mul rep            | Just p <- exactLog2 n ->                  Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)])-        -- The optimization for division by power of 2 is technically duplicated, but since at least one other part of ghc uses-        -- the pure `constantFoldExpr` this remains         MO_U_Quot rep            | Just p <- exactLog2 n ->                  Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)])@@ -435,19 +409,46 @@                  Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])         MO_S_Quot rep            | Just p <- exactLog2 n,-             CmmReg _ <- x ->+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require+                                -- it is a reg.  FIXME: remove this restriction.                 Just $! (cmmMachOpFold platform (MO_S_Shr rep)-                  [signedQuotRemHelper platform n x rep p, CmmLit (CmmInt p $ wordWidth platform)])+                  [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)])         MO_S_Rem rep            | Just p <- exactLog2 n,-             CmmReg _ <- x ->+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require+                                -- it is a reg.  FIXME: remove this restriction.                 -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).                 -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)                 -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.                 Just $! (cmmMachOpFold platform (MO_Sub rep)                     [x, cmmMachOpFold platform (MO_And rep)-                      [signedQuotRemHelper platform n x rep p, CmmLit (CmmInt (- n) rep)]])+                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])         _ -> Nothing+  where+    -- In contrast with unsigned integers, for signed ones+    -- shift right is not the same as quot, because it rounds+    -- to minus infinity, whereas quot rounds toward zero.+    -- To fix this up, we add one less than the divisor to the+    -- dividend if it is a negative number.+    --+    -- to avoid a test/jump, we use the following sequence:+    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)+    --      x2 = y & (divisor-1)+    --      result = x + x2+    -- this could be done a bit more simply using conditional moves,+    -- but we're processor independent here.+    --+    -- we optimise the divide by 2 case slightly, generating+    --      x1 = x >> word_size-1  (unsigned)+    --      return = x + x1+    signedQuotRemHelper :: Width -> Integer -> CmmExpr+    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]+      where+        bits = fromIntegral (widthInBits rep) - 1+        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep+        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)]+        x2 = if p == 1 then x1 else+             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]  -- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x -- Unfortunately this needs a unique supply because x might not be a@@ -481,533 +482,3 @@ isPicReg :: CmmExpr -> Bool isPicReg (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) = True isPicReg _ = False--canOptimizeDivision :: CmmConfig -> Width -> Bool-canOptimizeDivision cfg rep = cmmOptConstDivision cfg &&-  -- we can either widen the arguments to simulate mul2 or use mul2 directly for the platform word size-  (rep < wordWidth platform || (rep == wordWidth platform && cmmAllowMul2 cfg))-  where platform = cmmPlatform cfg---- -------------------------------------------------------------------------------- Folding callish machops--cmmCallishMachOpFold :: CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (CmmNode O O)-cmmCallishMachOpFold op res args =-  fromMaybe (CmmUnsafeForeignCall (PrimTarget op) res args) <$> (getConfig >>= \cfg -> cmmCallishMachOpFoldM cfg op res args)--cmmCallishMachOpFoldM :: CmmConfig -> CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (Maybe (CmmNode O O))---- If possible move the literals to the right, the following cases assume that to be the case-cmmCallishMachOpFoldM cfg op res [x@(CmmLit _),y]-  | isCommutableCallishMachOp op && not (isLit y) = cmmCallishMachOpFoldM cfg op res [y,x]---- Both arguments are literals, replace with the result-cmmCallishMachOpFoldM _ op res [CmmLit (CmmInt x _), CmmLit (CmmInt y _)]-  = case op of-    MO_S_Mul2 rep-      | [rHiNeeded,rHi,rLo] <- res -> do-          let resSz = widthInBits rep-              resVal = (narrowS rep x) * (narrowS rep y)-              high = resVal `shiftR` resSz-              low = narrowS rep resVal-              isHiNeeded = high /= low `shiftR` resSz-              isHiNeededVal = if isHiNeeded then 1 else 0-          prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt isHiNeededVal rep)-          prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt high rep)-          pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt low rep)-    MO_U_Mul2 rep-      | [rHi,rLo] <- res -> do-          let resSz = widthInBits rep-              resVal = (narrowU rep x) * (narrowU rep y)-              high = resVal `shiftR` resSz-              low = narrowU rep resVal-          prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt high rep)-          pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt low rep)-    MO_S_QuotRem rep-      | [rQuot, rRem] <- res,-        y /= 0 -> do-          let (q,r) = quotRem (narrowS rep x) (narrowS rep y)-          prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt q rep)-          pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt r rep)-    MO_U_QuotRem rep-      | [rQuot, rRem] <- res,-        y /= 0 -> do-          let (q,r) = quotRem (narrowU rep x) (narrowU rep y)-          prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt q rep)-          pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt r rep)-    _ -> pure Nothing---- 0, 1 or -1 as one of the constants--cmmCallishMachOpFoldM _ op res [_, CmmLit (CmmInt 0 _)]-  = case op of-    -- x * 0 == 0-    MO_S_Mul2 rep-      | [rHiNeeded, rHi, rLo] <- res -> do-        prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt 0 rep)-        prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep)-        pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt 0 rep)-    -- x * 0 == 0-    MO_U_Mul2 rep-      | [rHi, rLo] <- res -> do-        prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep)-        pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt 0 rep)-    _ -> pure Nothing--cmmCallishMachOpFoldM _ op res [CmmLit (CmmInt 0 _), _]-  = case op of-    -- 0 quotRem d == (0,0)-    MO_S_QuotRem rep-      | [rQuot, rRem] <- res -> do-      prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt 0 rep)-      pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)-    -- 0 quotRem d == (0,0)-    MO_U_QuotRem rep-      | [rQuot,rRem] <- res -> do-      prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt 0 rep)-      pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)-    _ -> pure Nothing--cmmCallishMachOpFoldM cfg op res [x, CmmLit (CmmInt 1 _)]-  = case op of-    -- x * 1 == x -- Note: The high word needs to be a sign extension of the low word, so we use a sign extending shift-    MO_S_Mul2 rep-      | [rHiNeeded, rHi, rLo] <- res -> do-        let platform = cmmPlatform cfg-            wordRep = wordWidth platform-            repInBits = toInteger $ widthInBits rep-        prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt 0 rep)-        prependNode $! CmmAssign (CmmLocal rHi) (cmmMachOpFold platform (MO_S_Shr rep) [x, CmmLit $ CmmInt (repInBits - 1) wordRep])-        pure . Just $! CmmAssign (CmmLocal rLo) x-    -- x * 1 == x-    MO_U_Mul2 rep-      | [rHi, rLo] <- res -> do-        prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep)-        pure . Just $! CmmAssign (CmmLocal rLo) x-    -- x quotRem 1 == (x, 0)-    MO_S_QuotRem rep-      | [rQuot, rRem] <- res -> do-        prependNode $! CmmAssign (CmmLocal rQuot) x-        pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)-    -- x quotRem 1 == (x, 0)-    MO_U_QuotRem rep-      | [rQuot, rRem] <- res -> do-        prependNode $! CmmAssign (CmmLocal rQuot) x-        pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)-    _ -> pure Nothing---- handle quotRem with a constant divisor--cmmCallishMachOpFoldM cfg op res [n, CmmLit (CmmInt d' _)]-  = case op of-    MO_S_QuotRem rep-      | Just p <- exactLog2 d,-        [rQuot,rRem] <- res -> do-          n' <- intoRegister n (cmmBits rep)-          -- first prepend the optimized division by a power 2-          prependNode $! CmmAssign (CmmLocal rQuot)-            (cmmMachOpFold platform (MO_S_Shr rep)-              [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt p $ wordWidth platform)])-          -- then output an optimized remainder by a power of 2-          pure . Just $! CmmAssign (CmmLocal rRem)-            (cmmMachOpFold platform (MO_Sub rep)-              [n', cmmMachOpFold platform (MO_And rep)-                [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt (- d) rep)]])-      | canOptimizeDivision cfg rep,-        d /= (-1), d /= 0, d /= 1,-        [rQuot,rRem] <- res -> do-          -- we are definitely going to use n multiple times, so put it into a register-          n' <- intoRegister n (cmmBits rep)-          -- generate an optimized (signed) division of n by d-          q <- generateDivisionBySigned platform cfg rep n' d-          -- we also need the result multiple times to calculate the remainder-          q' <- intoRegister q (cmmBits rep)--          prependNode $! CmmAssign (CmmLocal rQuot) q'-          -- The remainder now becomes n - q * d-          pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]]-      where-        platform = cmmPlatform cfg-        d = narrowS rep d'-    MO_U_QuotRem rep-      | Just p <- exactLog2 d,-        [rQuot,rRem] <- res -> do-          -- first prepend the optimized division by a power 2-          prependNode $! CmmAssign (CmmLocal rQuot) $ CmmMachOp (MO_U_Shr rep) [n, CmmLit (CmmInt p $ wordWidth platform)]-          -- then output an optimized remainder by a power of 2-          pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_And rep) [n, CmmLit (CmmInt (d - 1) rep)]-      | canOptimizeDivision cfg rep,-        d /= 0, d /= 1,-        [rQuot,rRem] <- res -> do-          -- we are definitely going to use n multiple times, so put it into a register-          n' <- intoRegister n (cmmBits rep)-          -- generate an optimized (unsigned) division of n by d-          q <- generateDivisionByUnsigned platform cfg rep n' d-          -- we also need the result multiple times to calculate the remainder-          q' <- intoRegister q (cmmBits rep)--          prependNode $! CmmAssign (CmmLocal rQuot) q'-          -- The remainder now becomes n - q * d-          pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]]-      where-        platform = cmmPlatform cfg-        d = narrowU rep d'-    _ -> pure Nothing--cmmCallishMachOpFoldM _ _ _ _ = pure Nothing---- -------------------------------------------------------------------------------- Specialized constant folding for MachOps which sometimes need to expand into multiple nodes--cmmMachOpFoldOptM :: CmmConfig -> MachOp -> [CmmExpr] -> Opt (Maybe CmmExpr)--cmmMachOpFoldOptM cfg op [n, CmmLit (CmmInt d' _)] =-  case op of-    MO_S_Quot rep-      -- recheck for power of 2 division. This may not be handled by cmmMachOpFoldM if n is not in a register-      | Just p <- exactLog2 d -> do-        n' <- intoRegister n (cmmBits rep)-        pure . Just $! cmmMachOpFold platform (MO_S_Shr rep)-          [ signedQuotRemHelper platform d n' rep p-          , CmmLit (CmmInt p $ wordWidth platform)-          ]-      | canOptimizeDivision cfg rep,-        d /= (-1), d /= 0, d /= 1 -> Just <$!> generateDivisionBySigned platform cfg rep n d-      where d = narrowS rep d'-    MO_S_Rem rep-      -- recheck for power of 2 remainder. This may not be handled by cmmMachOpFoldM if n is not in a register-      | Just p <- exactLog2 d -> do-        n' <- intoRegister n (cmmBits rep)-        pure . Just $! cmmMachOpFold platform (MO_Sub rep)-          [ n'-          , cmmMachOpFold platform (MO_And rep)-              [ signedQuotRemHelper platform d n' rep p-              , CmmLit (CmmInt (- d) rep)-              ]-          ]-      | canOptimizeDivision cfg rep,-        d /= (-1), d /= 0, d /= 1 -> do-        n' <- intoRegister n (cmmBits rep)-        -- first generate the division-        q <- generateDivisionBySigned platform cfg rep n' d-        -- then calculate the remainder by n - q * d-        pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]]-      where d = narrowS rep d'-    MO_U_Quot rep-      -- No need to recheck power of 2 division because cmmMachOpFoldM always handles that case-      | canOptimizeDivision cfg rep,-        d /= 0, d /= 1, Nothing <- exactLog2 d -> Just <$!> generateDivisionByUnsigned platform cfg rep n d-      where d = narrowU rep d'-    MO_U_Rem rep-      -- No need to recheck power of 2 remainder because cmmMachOpFoldM always handles that case-      | canOptimizeDivision cfg rep,-        d /= 0, d /= 1, Nothing <- exactLog2 d -> do-        n' <- intoRegister n (cmmBits rep)-        -- first generate the division-        q <- generateDivisionByUnsigned platform cfg rep n d-        -- then calculate the remainder by n - q * d-        pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]]-      where d = narrowU rep d'-    _ -> pure Nothing-  where platform = cmmPlatform cfg--cmmMachOpFoldOptM _ _ _ = pure Nothing---- -------------------------------------------------------------------------------- Utils for prepending new nodes---- Move an expression into a register to possibly use it multiple times-intoRegister :: CmmExpr -> CmmType -> Opt CmmExpr-intoRegister e@(CmmReg _) _ = pure e-intoRegister expr ty = do-  u <- getUniqueM-  let reg = LocalReg u ty-  CmmReg (CmmLocal reg) <$ prependNode (CmmAssign (CmmLocal reg) expr)--prependNode :: CmmNode O O -> Opt ()-prependNode n = Opt $ \_ xs -> pure (xs ++ [n], ())---- -------------------------------------------------------------------------------- Division by constants utils---- Helper for division by a power of 2--- In contrast with unsigned integers, for signed ones--- shift right is not the same as quot, because it rounds--- to minus infinity, whereas quot rounds toward zero.--- To fix this up, we add one less than the divisor to the--- dividend if it is a negative number.------ to avoid a test/jump, we use the following sequence:---      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)---      x2 = y & (divisor-1)---      result = x + x2--- this could be done a bit more simply using conditional moves,--- but we're processor independent here.------ we optimize the divide by 2 case slightly, generating---      x1 = x >> word_size-1  (unsigned)---      return = x + x1-signedQuotRemHelper :: Platform -> Integer -> CmmExpr -> Width -> Integer -> CmmExpr-signedQuotRemHelper platform n x rep p = CmmMachOp (MO_Add rep) [x, x2]-  where-    bits = fromIntegral (widthInBits rep) - 1-    shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep-    x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)]-    x2 = if p == 1 then x1 else-          CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]--{- Note: [Division by constants]--Integer division is floor(n / d), the goal is to find m,p-such that floor((m * n) / 2^p) = floor(n / d).--The idea being: n/d = n * (1/d). But we cannot store 1/d in an integer without-some error, so we choose some 2^p / d such that the error ends up small and-thus vanishes when we divide by 2^p again.--The algorithm below to generate these numbers is taken from Hacker's Delight-Second Edition Chapter 10 "Integer division by constants". The chapter also-contains proof that this method does indeed produce correct results.--However this is a much more literal interpretation of the algorithm,-which we can use because of the unbounded Integer type. Hacker's Delight-also provides a much more complex algorithm which computes these numbers-without the need to exceed the word size, but that is not necessary here.--}--generateDivisionBySigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr---- Sanity checks, division will generate incorrect results or undesirable code for these cases--- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases!-generateDivisionBySigned _ _ _ _ 0 = panic "generate signed division with 0"-generateDivisionBySigned _ _ _ _ 1 = panic "generate signed division with 1"-generateDivisionBySigned _ _ _ _ (-1) = panic "generate signed division with -1"-generateDivisionBySigned _ _ _ _ d | Just _ <- exactLog2 d = panic $ "generate signed division with " ++ show d--generateDivisionBySigned platform _cfg rep n divisor = do-  -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register-  n' <- if sign == 0 then pure n else intoRegister n resRep--  -- Set up mul2-  (shift', qExpr) <- mul2 n'--  -- add/subtract n if necessary-  let qExpr' = case sign of-        1  -> CmmMachOp (MO_Add rep) [qExpr, n']-        -1 -> CmmMachOp (MO_Sub rep) [qExpr, n']-        _  -> qExpr--  qExpr'' <- intoRegister (cmmMachOpFold platform (MO_S_Shr rep) [qExpr', CmmLit $ CmmInt shift' wordRep]) resRep--  -- Lastly add the sign of the quotient to correct for negative results-  pure $! cmmMachOpFold platform-    (MO_Add rep) [qExpr'', cmmMachOpFold platform (MO_U_Shr rep) [qExpr'', CmmLit $ CmmInt (toInteger $ widthInBits rep - 1) wordRep]]-  where-    resRep = cmmBits rep-    wordRep = wordWidth platform-    (magic, sign, shift) = divisionMagicS rep divisor-    -- generate the multiply with the magic number-    mul2 n-      -- Using mul2 for sub-word sizes regresses for signed integers only-      | rep == wordWidth platform = do-        (r1, r2, r3) <- (,,) <$> getUniqueM <*> getUniqueM <*> getUniqueM-        let rg1    = LocalReg r1 resRep-            resReg = LocalReg r2 resRep-            rg3    = LocalReg r3 resRep-        res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_S_Mul2 rep)) [rg1, resReg, rg3] [n, CmmLit $ CmmInt magic rep])-        pure (shift, res)-      -- widen the register and multiply without the MUL2 instruction-      -- if we don't need an additional add after this we can combine the shifts-      | otherwise = pure (if sign == 0 then 0 else shift, res)-          where-            wordRep = wordWidth platform-            -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow-            res = cmmMachOpFold platform (MO_SS_Conv wordRep rep)-                    [ cmmMachOpFold platform (MO_S_Shr wordRep)-                      [ cmmMachOpFold platform (MO_Mul wordRep)-                        [ cmmMachOpFold platform (MO_SS_Conv rep wordRep) [n]-                        , CmmLit $ CmmInt magic wordRep-                        ]-                      -- Check if we need to generate an add/subtract later. If not we can combine this with the postshift-                      , CmmLit $ CmmInt ((if sign == 0 then toInteger shift else 0) + (toInteger $ widthInBits rep)) wordRep-                      ]-                    ]---- See hackers delight for how and why this works (chapter in note [Division by constants])-divisionMagicS :: Width -> Integer -> (Integer, Integer, Integer)-divisionMagicS rep divisor = (magic, sign, toInteger $ p - wSz)-  where-    sign = if divisor > 0-      then if magic < 0 then 1 else 0-      else if magic < 0 then 0 else -1-    wSz = widthInBits rep-    ad = abs divisor-    t = (1 `shiftL` (wSz - 1)) + if divisor > 0 then 0 else 1-    anc = t - 1 - rem t ad-    go p'-      | twoP > anc * (ad - rem twoP ad) = p'-      | otherwise = go (p' + 1)-      where twoP = 1 `shiftL` p'-    p = go wSz-    am = (twoP + ad - rem twoP ad) `quot` ad-      where twoP = 1 `shiftL` p-    magic = narrowS rep $ if divisor > 0 then am else -am--generateDivisionByUnsigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr--- Sanity checks, division will generate incorrect results or undesirable code for these cases--- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases!-generateDivisionByUnsigned _ _ _ _ 0 = panic "generate signed division with 0"-generateDivisionByUnsigned _ _ _ _ 1 = panic "generate signed division with 1"-generateDivisionByUnsigned _ _ _ _ d | Just _ <- exactLog2 d = panic $ "generate signed division with " ++ show d--generateDivisionByUnsigned platform cfg rep n divisor = do-  -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register-  n' <- if not needsAdd -- Invariant: We also never preshift if we need an add, thus we don't need n in a register-    then pure $! cmmMachOpFold platform (MO_U_Shr rep) [n, CmmLit $ CmmInt preShift wordRep]-    else intoRegister n resRep--  -- Set up mul2-  (postShift', qExpr) <- mul2 n'--  -- add/subtract n if necessary-  let qExpr' = if needsAdd-        -- This is qExpr + (n - qExpr) / 2 = (qExpr + n) / 2 but with a guarantee that it'll not overflow-        then cmmMachOpFold platform (MO_Add rep)-          [ cmmMachOpFold platform (MO_U_Shr rep)-            [ cmmMachOpFold platform (MO_Sub rep) [n', qExpr]-            , CmmLit $ CmmInt 1 wordRep-            ]-          , qExpr-          ]-        else qExpr-      -- If we already divided by 2 in the add, remember to shift one bit less-      -- Hacker's Delight, Edition 2 Page 234: postShift > 0 if we needed an add, except if the divisor-      -- is 1, which we checked for above-      finalShift = if needsAdd then postShift' - 1 else postShift'--  -- apply the final postShift-  pure $! cmmMachOpFold platform (MO_U_Shr rep) [qExpr', CmmLit $ CmmInt finalShift wordRep]-  where-    resRep = cmmBits rep-    wordRep = wordWidth platform-    (preShift, magic, needsAdd, postShift) =-        let withPre = divisionMagicU rep True  divisor-            noPre   = divisionMagicU rep False divisor-        in case (withPre, noPre) of-          -- Use whatever does not cause us to take the expensive case-          ((_, _, False, _), (_, _, True, _)) -> withPre-          -- If we cannot avoid the expensive case, don't bother with the pre shift-          _ -> noPre-    -- generate the multiply with the magic number-    mul2 n-      | rep == wordWidth platform || (cmmAllowMul2 cfg && needsAdd) = do-        (r1, r2) <- (,) <$> getUniqueM <*> getUniqueM-        let rg1    = LocalReg r1 resRep-            resReg = LocalReg r2 resRep-        res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_U_Mul2 rep)) [resReg, rg1] [n, CmmLit $ CmmInt magic rep])-        pure (postShift, res)-      | otherwise = do-        pure (if needsAdd then postShift else 0, res)-          where-            wordRep = wordWidth platform-            -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow-            res = cmmMachOpFold platform (MO_UU_Conv wordRep rep)-              [ cmmMachOpFold platform (MO_U_Shr wordRep)-                [ cmmMachOpFold platform (MO_Mul wordRep)-                  [ cmmMachOpFold platform (MO_UU_Conv rep wordRep) [n]-                  , CmmLit $ CmmInt magic wordRep-                  ]-                -- Check if we need to generate an add later. If not we can combine this with the postshift-                , CmmLit $ CmmInt ((if needsAdd then 0 else postShift) + (toInteger $ widthInBits rep)) wordRep-                ]-              ]---- See hackers delight for how and why this works (chapter in note [Division by constants])--- The preshift isn't described there, but the idea is:--- If a divisor d has n trailing zeros, then d is a multiple of 2^n. Since we want to divide x by d--- we can also calculate (x / 2^n) / (d / 2^n) which may then not require an extra addition.------ The addition performs: quotient + dividend, but we need to avoid overflows, so we actually need to--- calculate: quotient + (dividend - quotient) / 2 = (quotient + dividend) / 2--- Thus if the preshift can avoid all of this, we have 1 operation in place of 3.------ The decision to use the preshift is made somewhere else, here we only report if the addition is needed-divisionMagicU :: Width -> Bool -> Integer -> (Integer, Integer, Bool, Integer)-divisionMagicU rep doPreShift divisor = (toInteger zeros, magic, needsAdd, toInteger $ p - wSz)-  where-    wSz = widthInBits rep-    zeros = if doPreShift then countTrailingZeros $ fromInteger @Word64 divisor else 0-    d = divisor `shiftR` zeros-    ones = ((1 `shiftL` wSz) - 1) `shiftR` zeros-    nc = ones - rem (ones - d) d-    go p'-      | twoP > nc * (d - 1 - rem (twoP - 1) d) = p'-      | otherwise = go (p' + 1)-      where twoP = 1 `shiftL` p'-    p = go wSz-    m = (twoP + d - 1 - rem (twoP - 1) d) `quot` d-      where twoP = 1 `shiftL` p-    needsAdd = d < 1 `shiftL` (p - wSz)-    magic = if needsAdd then m - (ones + 1) else m---- -------------------------------------------------------------------------------- Opt monad--newtype Opt a = OptI { runOptI :: CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a) }---- | Pattern synonym for 'Opt', as described in Note [The one-shot state--- monad trick].-pattern Opt :: (CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a)) -> Opt a-pattern Opt f <- OptI f-  where Opt f = OptI . oneShot $ \cfg -> oneShot $ \out -> f cfg out-{-# COMPLETE Opt #-}--runOpt :: CmmConfig -> Opt a -> UniqDSM ([CmmNode O O], a)-runOpt cf (Opt g) = g cf []--getConfig :: Opt CmmConfig-getConfig = Opt $ \cf xs -> pure (xs, cf)--instance Functor Opt where-  fmap f (Opt g) = Opt $ \cf xs -> fmap (fmap f) (g cf xs)--instance Applicative Opt where-  pure a = Opt $ \_ xs -> pure (xs, a)-  ff <*> fa = do-    f <- ff-    f <$> fa--instance Monad Opt where-  Opt g >>= f = Opt $ \cf xs -> do-    (ys, a) <- g cf xs-    runOptI (f a) cf ys--instance MonadGetUnique Opt where-  getUniqueM = Opt $ \_ xs -> (xs,) <$> getUniqueDSM--mapForeignTargetOpt :: (CmmExpr -> Opt CmmExpr) -> ForeignTarget -> Opt ForeignTarget-mapForeignTargetOpt exp   (ForeignTarget e c) = flip ForeignTarget c <$> exp e-mapForeignTargetOpt _   m@(PrimTarget _)      = pure m--wrapRecExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmExpr -> Opt CmmExpr-wrapRecExpOpt f (CmmMachOp op es)       = traverse (wrapRecExpOpt f) es >>= f . CmmMachOp op-wrapRecExpOpt f (CmmLoad addr ty align) = wrapRecExpOpt f addr >>= \newAddr -> f (CmmLoad newAddr ty align)-wrapRecExpOpt f e                       = f e--mapExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmNode e x -> Opt (CmmNode e x)-mapExpOpt _ f@(CmmEntry{})                          = pure f-mapExpOpt _ m@(CmmComment _)                        = pure m-mapExpOpt _ m@(CmmTick _)                           = pure m-mapExpOpt f   (CmmUnwind regs)                      = CmmUnwind <$> traverse (traverse (traverse f)) regs-mapExpOpt f   (CmmAssign r e)                       = CmmAssign r <$> f e-mapExpOpt f   (CmmStore addr e align)               = CmmStore <$> f addr <*> f e <*> pure align-mapExpOpt f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall <$> mapForeignTargetOpt f tgt <*> pure fs <*> traverse f as-mapExpOpt _ l@(CmmBranch _)                         = pure l-mapExpOpt f   (CmmCondBranch e ti fi l)             = f e >>= \newE -> pure (CmmCondBranch newE ti fi l)-mapExpOpt f   (CmmSwitch e ids)                     = flip CmmSwitch ids <$> f e-mapExpOpt f   n@CmmCall {cml_target=tgt}            = f tgt >>= \newTgt -> pure n{cml_target = newTgt}-mapExpOpt f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl)-                                                    = do-                                                      newTgt <- mapForeignTargetOpt f tgt-                                                      newAs <- traverse f as-                                                      pure $ CmmForeignCall newTgt fs newAs succ ret_args updfr intrbl
compiler/GHC/Cmm/Parser.y view
@@ -1321,6 +1321,7 @@   ( fsLit "PROF_HEADER_CREATE",     \[e] -> profHeaderCreate e ),    ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),+  ( fsLit "PUSH_BH_UPD_FRAME",     \[sp,e] -> emitPushBHUpdateFrame sp e ),   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->                                         emitSetDynHdr ptr info ccs ),   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->@@ -1335,6 +1336,10 @@ emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () emitPushUpdateFrame sp e = do   emitUpdateFrame sp mkUpdInfoLabel e++emitPushBHUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()+emitPushBHUpdateFrame sp e = do+  emitUpdateFrame sp mkBHUpdInfoLabel e  pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () pushStackFrame fields body = do
compiler/GHC/Cmm/Pipeline.hs view
@@ -137,12 +137,9 @@       dump Opt_D_dump_cmm_sp "Layout Stack" g        ----------- Sink and inline assignments  ---------------------------------      (g, dus) <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]-           if cmmOptSink cfg-              then pure $ runUniqueDSM dus $ cmmSink cfg g-              else return (g, dus)-      dump Opt_D_dump_cmm_sink "Sink assignments" g-+      g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]+           condPass (cmmOptSink cfg) (cmmSink platform) g+                    Opt_D_dump_cmm_sink "Sink assignments"        ------------- CAF analysis ----------------------------------------------       let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
compiler/GHC/Cmm/ProcPoint.hs view
@@ -263,7 +263,7 @@    let liveness = cmmGlobalLiveness platform g   let ppLiveness pp = filter (isArgReg . globalRegUse_reg) $ regSetToList $-                        expectJust "ppLiveness" $ mapLookup pp liveness+                        expectJust $ mapLookup pp liveness   graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g    -- Build a map from proc point BlockId to pairs of:@@ -325,7 +325,7 @@         (jumpEnv, jumpBlocks) <-            foldM add_jump_block (mapEmpty, []) needed_jumps             -- update the entry block-        let b = expectJust "block in env" $ mapLookup ppId blockEnv+        let b = expectJust $ mapLookup ppId blockEnv             blockEnv' = mapInsert ppId b blockEnv             -- replace branches to procpoints with branches to jumps             blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'@@ -343,7 +343,7 @@                                stack_info = stack_info})                      top_l live g'           | otherwise-          = case expectJust "pp label" $ mapLookup bid procLabels of+          = case expectJust $ mapLookup bid procLabels of               (lbl, Just info_lbl)                  -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)                                      , stack_info=stack_info})@@ -377,8 +377,8 @@           foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)                 (revPostorder g)   let sort_fn (bid, _) (bid', _) =-        compare (expectJust "block_order" $ mapLookup bid  block_order)-                (expectJust "block_order" $ mapLookup bid' block_order)+        compare (expectJust $ mapLookup bid  block_order)+                (expectJust $ mapLookup bid' block_order)    return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv 
compiler/GHC/Cmm/Sink.hs view
@@ -20,8 +20,6 @@  import GHC.Platform import GHC.Types.Unique.FM-import GHC.Types.Unique.DSM-import GHC.Cmm.Config  import Data.List (partition) import Data.Maybe@@ -152,10 +150,9 @@   --     y = e2   --     x = e1 -cmmSink :: CmmConfig -> CmmGraph -> UniqDSM CmmGraph-cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks+cmmSink :: Platform -> CmmGraph -> CmmGraph+cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks   where-  platform = cmmPlatform cfg   liveness = cmmLocalLivenessL platform graph   getLive l = mapFindWithDefault emptyLRegSet l liveness @@ -163,41 +160,11 @@    join_pts = findJoinPoints blocks -  sink :: LabelMap Assignments -> [CmmBlock] -> UniqDSM [CmmBlock]-  sink _ [] = pure []-  sink sunk (b:bs) = do-    -- Now sink and inline in this block-    (prepend, last_fold) <- runOpt cfg $ constantFoldNode last--    (middle', assigs) <- walk cfg (ann_middles ++ annotate platform live_middle prepend) (mapFindWithDefault [] lbl sunk)--    let (final_last, assigs') = tryToInline platform live last_fold assigs-        -- Now, drop any assignments that we will not sink any further.-        (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs'-        drop_if :: (LocalReg, CmmExpr, AbsMem)-                      -> [LRegSet] -> (Bool, [LRegSet])-        drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')-            where-              should_drop =  conflicts platform a final_last-                          || not (isTrivial platform rhs) && live_in_multi live_sets r-                          || r `elemLRegSet` live_in_joins--              live_sets' | should_drop = live_sets-                        | otherwise   = map upd live_sets--              upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs-                      | otherwise           = set--              live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs--        final_middle = foldl' blockSnoc middle' dropped_last--        sunk' = mapUnion sunk $-                  mapFromList [ (l, filterAssignments platform (getLive l) assigs'')-                              | l <- succs ]--    (blockJoin first final_middle final_last :) <$> sink sunk' bs-+  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]+  sink _ [] = []+  sink sunk (b:bs) =+    -- pprTrace "sink" (ppr lbl) $+    blockJoin first final_middle final_last : sink sunk' bs     where       lbl = entryLabel b       (first, middle, last) = blockSplit b@@ -211,6 +178,11 @@       live_middle = gen_killL platform last live       ann_middles = annotate platform live_middle (blockToList middle) +      -- Now sink and inline in this block+      (middle', assigs) = walk platform ann_middles (mapFindWithDefault [] lbl sunk)+      fold_last = constantFoldNode platform last+      (final_last, assigs') = tryToInline platform live fold_last assigs+       -- We cannot sink into join points (successors with more than       -- one predecessor), so identify the join points and the set       -- of registers live in them.@@ -228,6 +200,31 @@            (_one:_two:_) -> True            _ -> False +      -- Now, drop any assignments that we will not sink any further.+      (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs'++      drop_if :: (LocalReg, CmmExpr, AbsMem)+                      -> [LRegSet] -> (Bool, [LRegSet])+      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')+          where+            should_drop =  conflicts platform a final_last+                        || not (isTrivial platform rhs) && live_in_multi live_sets r+                        || r `elemLRegSet` live_in_joins++            live_sets' | should_drop = live_sets+                       | otherwise   = map upd live_sets++            upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs+                    | otherwise          = set++            live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs++      final_middle = foldl' blockSnoc middle' dropped_last++      sunk' = mapUnion sunk $+                 mapFromList [ (l, filterAssignments platform (getLive l) assigs'')+                             | l <- succs ]+ {- TODO: enable this later, when we have some good tests in place to    measure the effect and tune it. @@ -302,7 +299,7 @@ --    * a list of assignments that will be placed *after* that block. -- -walk :: CmmConfig+walk :: Platform      -> [(LRegSet, CmmNode O O)]    -- nodes of the block, annotated with                                         -- the set of registers live *after*                                         -- this node.@@ -312,39 +309,36 @@                                         -- Earlier assignments may refer                                         -- to later ones. -     -> UniqDSM ( Block CmmNode O O             -- The new block-               , Assignments                   -- Assignments to sink further-               )+     -> ( Block CmmNode O O             -- The new block+        , Assignments                   -- Assignments to sink further+        ) -walk cfg nodes assigs = go nodes emptyBlock assigs+walk platform nodes assigs = go nodes emptyBlock assigs  where-   platform = cmmPlatform cfg-   go []               block as = pure (block, as)+   go []               block as = (block, as)    go ((live,node):ns) block as     -- discard nodes representing dead assignment     | shouldDiscard node live             = go ns block as-    | otherwise = do-      (prepend, node1) <- runOpt cfg $ constantFoldNode node-      if not (null prepend)-        then go (annotate platform live (prepend ++ [node1]) ++ ns) block as-        else do-          let -- Inline assignments-              (node2, as1) = tryToInline platform live node1 as-              -- Drop any earlier assignments conflicting with node2-              (dropped, as') = dropAssignmentsSimple platform-                                (\a -> conflicts platform a node2) as1-              -- Walk over the rest of the block. Includes dropped assignments-              block' = foldl' blockSnoc block dropped `blockSnoc` node2+    -- sometimes only after simplification we can tell we can discard the node.+    -- See Note [Discard simplified nodes]+    | noOpAssignment node2                = go ns block as+    -- Pick up interesting assignments+    | Just a <- shouldSink platform node2 = go ns block (a : as1)+    -- Try inlining, drop assignments and move on+    | otherwise                           = go ns block' as'+    where+      -- Simplify node+      node1 = constantFoldNode platform node -          (prepend2, node3) <- runOpt cfg $ constantFoldNode node2-          if | not (null prepend2)                 -> go (annotate platform live (prepend2 ++ [node3]) ++ ns) block as-             -- sometimes only after simplification we can tell we can discard the node.-             -- See Note [Discard simplified nodes]-             | noOpAssignment node3                -> go ns block as-             -- Pick up interesting assignments-             | Just a <- shouldSink platform node3 -> go ns block (a : as1)-             -- Try inlining, drop assignments and move on-             | otherwise                           -> go ns block' as'+      -- Inline assignments+      (node2, as1) = tryToInline platform live node1 as++      -- Drop any earlier assignments conflicting with node2+      (dropped, as') = dropAssignmentsSimple platform+                          (\a -> conflicts platform a node2) as1++      -- Walk over the rest of the block. Includes dropped assignments+      block' = foldl' blockSnoc block dropped `blockSnoc` node2  {- Note [Discard simplified nodes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/CmmToAsm.hs view
@@ -68,6 +68,7 @@ import qualified GHC.CmmToAsm.AArch64 as AArch64 import qualified GHC.CmmToAsm.Wasm as Wasm32 import qualified GHC.CmmToAsm.RV64  as RV64+import qualified GHC.CmmToAsm.LA64 as LA64  import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear                as Linear@@ -151,7 +152,7 @@       ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"       ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"       ArchRISCV64   -> nCG' (RV64.ncgRV64 config)-      ArchLoongArch64->panic "nativeCodeGen: No NCG for LoongArch64"+      ArchLoongArch64 -> nCG' (LA64.ncgLA64 config)       ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"       ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"       ArchWasm32    -> Wasm32.ncgWasm config logger platform ts modLoc h cmms
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -1,5 +1,6 @@ {-# language GADTs, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+ module GHC.CmmToAsm.AArch64.CodeGen (       cmmTopCodeGen     , generateJumpTableForInstr@@ -23,7 +24,7 @@ import GHC.CmmToAsm.Monad    ( NatM, getNewRegNat    , getPicBaseMaybeNat, getPlatform, getConfig-   , getDebugBlock, getFileId, getThisModuleNat+   , getDebugBlock, getFileId, getNewLabelNat, getThisModuleNat    ) -- import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC@@ -50,7 +51,7 @@ import GHC.Data.OrdList import GHC.Utils.Outputable -import Control.Monad    ( mapAndUnzipM, foldM )+import Control.Monad    ( mapAndUnzipM ) import GHC.Float  import GHC.Types.Basic@@ -209,43 +210,83 @@ -- ----------------------------------------------------------------------------- -- Generating a table-branch --- TODO jump tables would be a lot faster, but we'll use bare bones for now.--- this is usually done by sticking the jump table ids into an instruction--- and then have the @generateJumpTableForInstr@ callback produce the jump--- table as a static.------ See Ticket 19912------ data SwitchTargets =---    SwitchTargets---        Bool                       -- Signed values---        (Integer, Integer)         -- Range---        (Maybe Label)              -- Default value---        (M.Map Integer Label)      -- The branches------ Non Jumptable plan:--- xE <- expr+-- | Generate jump to jump table target ---genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock-genSwitch expr targets = do -- pprPanic "genSwitch" (ppr expr)-  (reg, format, code) <- getSomeReg expr-  let w = formatToWidth format-  let mkbranch acc (key, bid) = do-        (keyReg, _format, code) <- getSomeReg (CmmLit (CmmInt key w))-        return $ code `appOL`-                 toOL [ CMP (OpReg w reg) (OpReg w keyReg)-                      , BCOND EQ (TBlock bid)-                      ] `appOL` acc-      def_code = case switchTargetsDefault targets of-        Just bid -> unitOL (B (TBlock bid))-        Nothing  -> nilOL--  switch_code <- foldM mkbranch nilOL (switchTargetsCases targets)-  return $ code `appOL` switch_code `appOL` def_code+-- The index into the jump table is calulated by evaluating @expr@. The+-- corresponding table entry contains the relative address to jump to (relative+-- to the jump table's first entry / the table's own label).+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch config expr targets = do+  (reg, fmt1, e_code) <- getSomeReg indexExpr+  let fmt = II64+  targetReg <- getNewRegNat fmt+  lbl <- getNewLabelNat+  dynRef <- cmmMakeDynamicReference config DataReference lbl+  (tableReg, fmt2, t_code) <- getSomeReg dynRef+  let code =+        toOL+          [ COMMENT (text "indexExpr" <+> (text . show) indexExpr),+            COMMENT (text "dynRef" <+> (text . show) dynRef)+          ]+          `appOL` e_code+          `appOL` t_code+          `appOL` toOL+            [ COMMENT (ftext "Jump table for switch"),+              -- index to offset into the table (relative to tableReg)+              annExpr expr (LSL (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))),+              -- calculate table entry address+              ADD (OpReg W64 targetReg) (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt2) tableReg),+              -- load table entry (relative offset from tableReg (first entry) to target label)+              LDR II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))),+              -- calculate absolute address of the target label+              ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg),+              -- prepare jump to target label+              J_TBL ids (Just lbl) targetReg+            ]+  return code+  where+    -- See Note [Sub-word subtlety during jump-table indexing] in+    -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.+    indexExpr0 = cmmOffset platform expr offset+    -- We widen to a native-width register to sanitize the high bits+    indexExpr =+      CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+    expr_w = cmmExprWidth platform expr+    (offset, ids) = switchTargetsToTable targets+    platform = ncgPlatform config --- We don't do jump tables for now, see Ticket 19912-generateJumpTableForInstr :: NCGConfig -> Instr-  -> Maybe (NatCmmDecl RawCmmStatics Instr)+-- | Generate jump table data (if required)+--+-- The idea is to emit one table entry per case. The entry is the relative+-- address of the block to jump to (relative to the table's first entry /+-- table's own label.) The calculation itself is done by the linker.+generateJumpTableForInstr ::+  NCGConfig ->+  Instr ->+  Maybe (NatCmmDecl RawCmmStatics Instr)+generateJumpTableForInstr config (J_TBL ids (Just lbl) _) =+  let jumpTable =+        map jumpTableEntryRel ids+        where+          jumpTableEntryRel Nothing =+            CmmStaticLit (CmmInt 0 (ncgWordWidth config))+          jumpTableEntryRel (Just blockid) =+            CmmStaticLit+              ( CmmLabelDiffOff+                  blockLabel+                  lbl+                  0+                  (ncgWordWidth config)+              )+            where+              blockLabel = blockLbl blockid+      sectionType = case platformOS (ncgPlatform config) of+        -- Aarch64 Windows platform requires LLVM 20 to support .rodata+        OSMinGW32 -> Text+        _         -> ReadOnlyData+   in Just (CmmData (Section sectionType lbl) (CmmStaticsRaw lbl jumpTable)) generateJumpTableForInstr _ _ = Nothing  -- -----------------------------------------------------------------------------@@ -266,6 +307,7 @@ stmtToInstrs stmt = do   -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"   --     ++ showSDocUnsafe (ppr stmt)+  config <- getConfig   platform <- getPlatform   case stmt of     CmmUnsafeForeignCall target result_regs args@@ -294,7 +336,7 @@       CmmCondBranch arg true false _prediction ->           genCondBranch true false arg -      CmmSwitch arg ids -> genSwitch arg ids+      CmmSwitch arg ids -> genSwitch config arg ids        CmmCall { cml_target = arg } -> genJump arg @@ -339,12 +381,6 @@         -- ones which map to a real machine register on this         -- platform.  Hence if it's not mapped to a registers something         -- went wrong earlier in the pipeline.--- | Convert a BlockId to some CmmStatic data--- TODO: Add JumpTable Logic, see Ticket 19912--- jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic--- jumpTableEntry config Nothing   = CmmStaticLit (CmmInt 0 (ncgWordWidth config))--- jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)---     where blockLabel = blockLbl blockid  -- ----------------------------------------------------------------------------- -- General things for putting together code sequences@@ -796,11 +832,7 @@         MO_V_Add {} -> notUnary         MO_V_Sub {} -> notUnary         MO_V_Mul {} -> notUnary-        MO_VS_Quot {} -> notUnary-        MO_VS_Rem {} -> notUnary         MO_VS_Neg {} -> notUnary-        MO_VU_Quot {} -> notUnary-        MO_VU_Rem {} -> notUnary         MO_V_Shuffle {} -> notUnary         MO_VF_Shuffle  {} -> notUnary         MO_VF_Insert {} -> notUnary@@ -1189,11 +1221,7 @@         MO_V_Add {} -> vectorsNeedLlvm         MO_V_Sub {} -> vectorsNeedLlvm         MO_V_Mul {} -> vectorsNeedLlvm-        MO_VS_Quot {} -> vectorsNeedLlvm-        MO_VS_Rem {} -> vectorsNeedLlvm         MO_VS_Neg {} -> vectorsNeedLlvm-        MO_VU_Quot {} -> vectorsNeedLlvm-        MO_VU_Rem {} -> vectorsNeedLlvm         MO_VF_Extract {} -> vectorsNeedLlvm         MO_VF_Add {} -> vectorsNeedLlvm         MO_VF_Sub {} -> vectorsNeedLlvm@@ -2121,7 +2149,7 @@         -- Conversion         MO_UF_Conv w        -> mkCCall (word2FloatLabel w) -        -- Arithmatic+        -- Arithmetic         -- These are not supported on X86, so I doubt they are used much.         MO_S_QuotRem  _w -> unsupported mop         MO_U_QuotRem  _w -> unsupported mop@@ -2131,6 +2159,16 @@         MO_SubWordC   _w -> unsupported mop         MO_AddIntC    _w -> unsupported mop         MO_SubIntC    _w -> unsupported mop++        -- Vector+        MO_VS_Quot {} -> unsupported mop+        MO_VS_Rem {} -> unsupported mop+        MO_VU_Quot {} -> unsupported mop+        MO_VU_Rem {} -> unsupported mop+        MO_I64X2_Min -> unsupported mop+        MO_I64X2_Max -> unsupported mop+        MO_W64X2_Min -> unsupported mop+        MO_W64X2_Max -> unsupported mop          -- Memory Ordering         -- Set flags according to their C pendants (stdatomic.h):
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -29,7 +29,7 @@  import GHC.Utils.Panic -import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, catMaybes)  import GHC.Stack @@ -120,6 +120,7 @@   ORR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   -- 4. Branch Instructions ----------------------------------------------------   J t                      -> usage (regTarget t, [])+  J_TBL _ _ t              -> usage ([t], [])   B t                      -> usage (regTarget t, [])   BCOND _ t                -> usage (regTarget t, [])   BL t ps                  -> usage (regTarget t ++ ps, callerSavedRegisters)@@ -210,7 +211,7 @@ -- | <---- argument passing -------------> | <-- callee saved (lower 64 bits) ---> | <--------------------------------------- caller saved ----------------------> | -- | <------ free registers -------------> | F1 | F2 | F3 | F4 | D1 | D2 | D3 | D4 | <------ free registers -----------------------------------------------------> | -- '---------------------------------------------------------------------------------------------------------------------------------------------------------------'--- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer+-- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register (See Note [Aarch64 Register x18 at Darwin and Windows]), FP: Frame pointer, LR: Link register, SP: Stack pointer -- BR: Base, SL: SpLim -- -- TODO: The zero register is currently mapped to -1 but should get it's own separate number.@@ -275,10 +276,11 @@     ORR o1 o2 o3   -> ORR  (patchOp o1) (patchOp o2) (patchOp o3)      -- 4. Branch Instructions ---------------------------------------------------    J t            -> J (patchTarget t)-    B t            -> B (patchTarget t)-    BL t rs        -> BL (patchTarget t) rs-    BCOND c t      -> BCOND c (patchTarget t)+    J t               -> J (patchTarget t)+    J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t)+    B t               -> B (patchTarget t)+    BL t rs           -> BL (patchTarget t) rs+    BCOND c t         -> BCOND c (patchTarget t)      -- 5. Atomic Instructions --------------------------------------------------     -- 6. Conditional Instructions ---------------------------------------------@@ -332,6 +334,7 @@     CBZ{} -> True     CBNZ{} -> True     J{} -> True+    J_TBL{} -> True     B{} -> True     BL{} -> True     BCOND{} -> True@@ -345,6 +348,7 @@ jumpDestsOfInstr (CBZ _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr (CBNZ _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids jumpDestsOfInstr (B t) = [id | TBlock id <- [t]] jumpDestsOfInstr (BL t _) = [ id | TBlock id <- [t]] jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]]@@ -353,6 +357,11 @@ canFallthroughTo :: Instr -> BlockId -> Bool canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid canFallthroughTo (J (TBlock target)) bid = bid == target+canFallthroughTo (J_TBL targets _ _) bid = all isTargetBid targets+  where+    isTargetBid target = case target of+      Nothing -> True+      Just target -> target == bid canFallthroughTo (B (TBlock target)) bid = bid == target canFallthroughTo _ _ = False @@ -366,6 +375,7 @@         CBZ r (TBlock bid) -> CBZ r (TBlock (patchF bid))         CBNZ r (TBlock bid) -> CBNZ r (TBlock (patchF bid))         J (TBlock bid) -> J (TBlock (patchF bid))+        J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r         B (TBlock bid) -> B (TBlock (patchF bid))         BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps         BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))@@ -668,6 +678,7 @@     | CBNZ Operand Target -- if op /= 0, then branch.     -- Branching.     | J Target            -- like B, but only generated from genJump. Used to distinguish genJumps from others.+    | J_TBL [Maybe BlockId] (Maybe CLabel) Reg -- A jump instruction with data for switch/jump tables     | B Target            -- unconditional branching b/br. (To a blockid, label or register)     | BL Target [Reg] -- branch and link (e.g. set x30 to next pc, and branch)     | BCOND Cond Target   -- branch with condition. b.<cond>@@ -758,6 +769,7 @@       CBZ{} -> "CBZ"       CBNZ{} -> "CBNZ"       J{} -> "J"+      J_TBL {} -> "J_TBL"       B{} -> "B"       BL{} -> "BL"       BCOND{} -> "BCOND"
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}  module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr, pprBasicBlock) where @@ -43,7 +42,9 @@         pprSectionAlign config (Section Text lbl) $$         -- do not         -- pprProcAlignment config $$-        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed+        (if lbl /= blockLbl (blockId (head blocks)) -- blocks can have clashed names+          then pprLabel platform lbl -- blocks guaranteed not null, so label needed+          else empty) $$         vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$         (if ncgDwarfEnabled config          then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$@@ -425,6 +426,7 @@    -- 4. Branch Instructions ----------------------------------------------------   J t            -> pprInstr platform (B t)+  J_TBL _ _ r    -> pprInstr platform (B (TReg r))   B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))   B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl   B (TReg r)     -> line $ text "\tbr" <+> pprReg W64 r@@ -460,63 +462,51 @@   STR _f o1 o2 -> op2 (text "\tstr") o1 o2   STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2 -#if defined(darwin_HOST_OS)   LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->-    op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$-    op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") $$-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.--  LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->-    op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$-    op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") $$-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.--  LDR _f o1 (OpImm (ImmIndex lbl off)) ->-    op_adrp o1 (pprAsmLabel platform lbl <> text "@page") $$-    op_add o1 (pprAsmLabel platform lbl <> text "@pageoff") $$-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.--  LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->-    op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$-    op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff")--  LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->-    op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$-    op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff")--  LDR _f o1 (OpImm (ImmCLbl lbl)) ->-    op_adrp o1 (pprAsmLabel platform lbl <> text "@page") $$-    op_add o1 (pprAsmLabel platform lbl <> text "@pageoff")--#else-  LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->-    op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$-    op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) $$-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.+    let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in+    op_adrp o1 (adrp') $$+    op_ldr o1 (ldr') $$+    op_add o1 (check_off off)    LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->-    op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$-    op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) $$-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.+    case platformOS platform of+      OSMinGW32 ->+        let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in+        op_adrp o1 (adrp') $$+        op_add o1 add' $$+        op_add o1 (check_off off)+      _ ->+        let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in+        op_adrp o1 (adrp') $$+        op_ldr o1 (ldr') $$+        op_add o1 (check_off off)    LDR _f o1 (OpImm (ImmIndex lbl off)) ->-    op_adrp o1 (pprAsmLabel platform lbl) $$-    op_add o1 (text ":lo12:" <> pprAsmLabel platform lbl) $$-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.+    let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in+    op_adrp o1 (adrp') $$+    op_add o1 (add') $$+    op_add o1 (check_off off)    LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->-    op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$-    op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl)+    let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in+    op_adrp o1 (adrp') $$+    op_ldr o1 (ldr')    LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->-    op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$-    op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl)+    case platformOS platform of+      OSMinGW32 ->+        let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in+        op_adrp o1 (adrp') $$+        op_add o1 add'+      _ ->+        let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in+        op_adrp o1 (adrp') $$+        op_ldr o1 (ldr')    LDR _f o1 (OpImm (ImmCLbl lbl)) ->-    op_adrp o1 (pprAsmLabel platform lbl) $$-    op_add o1 (text ":lo12:" <> pprAsmLabel platform lbl)--#endif+    let (adrp', ldr') = op_adrp_reloc_local $ pprAsmLabel platform lbl in+    op_adrp o1 adrp' $$+    op_add o1 ldr'    LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->     op2 (text "\tldrb") o1 o2@@ -551,6 +541,21 @@        op_ldr o1 rest      = line $ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]"        op_adrp o1 rest     = line $ text "\tadrp" <+> pprOp platform o1 <> comma <+> rest        op_add o1 rest      = line $ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest++       op_adrp_reloc_dynamic asm_lbl = case platformOS platform of+          OSDarwin -> (asm_lbl <> text "@gotpage", asm_lbl <> text "@gotpageoff")+          OSLinux -> (text ":got:" <> asm_lbl, text ":got_lo12:" <> asm_lbl)+          OSMinGW32 -> (text "__imp_" <> asm_lbl, text ":lo12:__imp_" <> asm_lbl)+          os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_dynamic : " ++ show os' ++ " is unsuppported by relocations"++       op_adrp_reloc_local asm_lbl = case platformOS platform of+          OSDarwin -> (asm_lbl <> text "@page", asm_lbl <> text "@pageoff")+          OSLinux -> (asm_lbl, text ":lo12:" <> asm_lbl)+          OSMinGW32 -> (asm_lbl, text ":lo12:" <> asm_lbl)+          os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_local : " ++ show os' ++ " is unsuppported by relocations"++       check_off off = if off >= 0 && off <= 4095 then char '#' <> int off else+         pgmError $ "GHC.CmmToAsm.AArch64.Ppr.check_off : " ++ show off ++ " is out of 12 bit"  pprBcond :: IsLine doc => Cond -> doc pprBcond c = text "b." <> pprCond c
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -508,8 +508,8 @@               union cFrom new_point             merge edges chains           where-            cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains-            cTo = expectJust "mergeChains:chainMap:to"   $ mapLookup to   chains+            cFrom = expectJust $ mapLookup from chains+            cTo = expectJust $ mapLookup to   chains   -- See Note [Chain based CFG serialization] for the general idea.@@ -757,7 +757,7 @@             --pprTraceIt "placedBlocks" $             -- ++ [] is still kinda expensive             if null unplaced then blockList else blockList ++ unplaced-        getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap+        getBlock bid = expectJust $ mapLookup bid blockMap     in         --Assert we placed all blocks given as input         assert (all (\bid -> mapMember bid blockMap) placedBlocks) $
compiler/GHC/CmmToAsm/CFG.hs view
@@ -311,8 +311,8 @@         cuts_vars <- traverse (\p -> (p,) <$> fresh (Just p)) (concatMap (\(a, b) -> [a] ++ maybe [] (:[]) b) cuts_list)         let cuts_map = mapFromList cuts_vars :: LabelMap (Point s (Maybe BlockId))         -- Then unify according to the rewrites in the cuts map-        mapM_ (\(from, to) -> expectJust "shortcutWeightMap" (mapLookup from cuts_map)-                              `union` expectJust "shortcutWeightMap" (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list+        mapM_ (\(from, to) -> expectJust (mapLookup from cuts_map)+                              `union` expectJust (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list         -- Then recover the unique representative, which is the result of following         -- the chain to the end.         mapM find cuts_map@@ -416,13 +416,10 @@     = Nothing  getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight-getEdgeWeight cfg from to =-    edgeWeight $ expectJust "Edgeweight for nonexisting block" $-                 getEdgeInfo from to cfg+getEdgeWeight cfg from to = edgeWeight $ expectJust $ getEdgeInfo from to cfg  getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource-getTransitionSource from to cfg = transitionSource $ expectJust "Source info for nonexisting block" $-                        getEdgeInfo from to cfg+getTransitionSource from to cfg = transitionSource $ expectJust $ getEdgeInfo from to cfg  reverseEdges :: CFG -> CFG reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg@@ -600,7 +597,7 @@  -} -- | Generate weights for a Cmm proc based on some simple heuristics.-getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG+getCfgProc :: Platform -> Weights -> GenCmmDecl d h CmmGraph -> CFG getCfgProc _        _       (CmmData {}) = mapEmpty getCfgProc platform weights (CmmProc _info _lab _live graph) = getCfg platform weights graph @@ -1004,7 +1001,7 @@     blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId     -- Map from blockId to indices starting at zero     toVertex :: BlockId -> Int-    toVertex   blockId  = expectJust "mkGlobalWeights" $ mapLookup blockId vertexMapping+    toVertex   blockId  = expectJust $ mapLookup blockId vertexMapping     -- Map from indices starting at zero to blockIds     fromVertex :: Int -> BlockId     fromVertex vertex   = blockMapping ! vertex
compiler/GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -241,6 +241,7 @@   ArchPPC_64 _ -> fromIntegral $ toRegNo r   ArchAArch64  -> fromIntegral $ toRegNo r   ArchRISCV64  -> fromIntegral $ toRegNo r+  ArchLoongArch64  -> fromIntegral $ toRegNo r   _other -> error "dwarfRegNo: Unsupported platform or unknown register!"  -- | Virtual register number to use for return address.@@ -255,4 +256,5 @@     ArchPPC_64 ELF_V2 -> 65 -- lr (link register)     ArchAArch64 -> 30     ArchRISCV64 -> 1 -- ra (return address)+    ArchLoongArch64 -> 1 -- ra (return address)     _other     -> error "dwarfReturnRegNo: Unsupported platform!"
compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -150,14 +150,14 @@ pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfo platform haveSrc d   = case d of-      DwarfCompileUnit {}  -> hasChildren-      DwarfSubprogram {}   -> hasChildren-      DwarfBlock {}        -> hasChildren-      DwarfSrcNote {}      -> noChildren+      DwarfCompileUnit {dwChildren = kids} -> hasChildren kids+      DwarfSubprogram  {dwChildren = kids} -> hasChildren kids+      DwarfBlock       {dwChildren = kids} -> hasChildren kids+      DwarfSrcNote {}                      -> noChildren   where-    hasChildren =+    hasChildren kids =         pprDwarfInfoOpen platform haveSrc d $$-        vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$+        vcat (map (pprDwarfInfo platform haveSrc) kids) $$         pprDwarfInfoClose     noChildren = pprDwarfInfoOpen platform haveSrc d {-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc #-}
+ compiler/GHC/CmmToAsm/LA64.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for LoongArch64 architectures+module GHC.CmmToAsm.LA64 ( ncgLA64 ) where++import GHC.Prelude++import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Types+import GHC.Utils.Outputable (ftext)++import qualified GHC.CmmToAsm.LA64.CodeGen  as LA64+import qualified GHC.CmmToAsm.LA64.Instr    as LA64+import qualified GHC.CmmToAsm.LA64.Ppr      as LA64+import qualified GHC.CmmToAsm.LA64.RegInfo  as LA64+import qualified GHC.CmmToAsm.LA64.Regs     as LA64++ncgLA64 :: NCGConfig -> NcgImpl RawCmmStatics LA64.Instr LA64.JumpDest+ncgLA64 config =+  NcgImpl+    { ncgConfig                 = config,+      cmmTopCodeGen             = LA64.cmmTopCodeGen,+      generateJumpTableForInstr = LA64.generateJumpTableForInstr config,+      getJumpDestBlockId        = LA64.getJumpDestBlockId,+      canShortcut               = LA64.canShortcut,+      shortcutStatics           = LA64.shortcutStatics,+      shortcutJump              = LA64.shortcutJump,+      pprNatCmmDeclS            = LA64.pprNatCmmDecl config,+      pprNatCmmDeclH            = LA64.pprNatCmmDecl config,+      maxSpillSlots             = LA64.maxSpillSlots config,+      allocatableRegs           = LA64.allocatableRegs platform,+      ncgAllocMoreStack         = LA64.allocMoreStack platform,+      ncgMakeFarBranches        = LA64.makeFarBranches,+      extractUnwindPoints       = const [],+      invertCondBranches        = \_ _ -> id+    }+  where+    platform = ncgPlatform config++-- | `Instruction` instance for LA64+instance Instruction LA64.Instr where+  regUsageOfInstr       = LA64.regUsageOfInstr+  patchRegsOfInstr _    = LA64.patchRegsOfInstr+  isJumpishInstr        = LA64.isJumpishInstr+  canFallthroughTo      = LA64.canFallthroughTo+  jumpDestsOfInstr      = LA64.jumpDestsOfInstr+  patchJumpInstr        = LA64.patchJumpInstr+  mkSpillInstr          = LA64.mkSpillInstr+  mkLoadInstr           = LA64.mkLoadInstr+  takeDeltaInstr        = LA64.takeDeltaInstr+  isMetaInstr           = LA64.isMetaInstr+  mkRegRegMoveInstr _ _ = LA64.mkRegRegMoveInstr+  takeRegRegMoveInstr _ = LA64.takeRegRegMoveInstr+  mkJumpInstr           = LA64.mkJumpInstr+  mkStackAllocInstr     = LA64.mkStackAllocInstr+  mkStackDeallocInstr   = LA64.mkStackDeallocInstr+  mkComment             = pure . LA64.COMMENT . ftext+  pprInstr              = LA64.pprInstr
+ compiler/GHC/CmmToAsm/LA64/CodeGen.hs view
@@ -0,0 +1,2236 @@+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE OverloadedStrings #-}+module GHC.CmmToAsm.LA64.CodeGen (+      cmmTopCodeGen+    , generateJumpTableForInstr+    , makeFarBranches+)++where++import Data.Maybe+import Data.Word+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.DebugBlock+import GHC.Cmm.Switch+import GHC.Cmm.Utils+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Monad+  ( NatM,+    getConfig,+    getDebugBlock,+    getFileId,+    getNewLabelNat,+    getNewRegNat,+    getPicBaseMaybeNat,+    getPlatform+  )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.LA64.Cond+import GHC.CmmToAsm.LA64.Instr+import GHC.CmmToAsm.LA64.Regs+import GHC.CmmToAsm.Types+import GHC.Data.FastString+import GHC.Data.OrdList+import GHC.Float+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Regs+import GHC.Prelude hiding (EQ)+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine)+import GHC.Types.Tickish (GenTickish (..))+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Monad+import Control.Monad+import GHC.Cmm.Dataflow.Label+import GHC.Types.Unique.DSM++-- [General layout of an NCG]+cmmTopCodeGen ::+  RawCmmDecl ->+  NatM [NatCmmDecl RawCmmStatics Instr]+-- Thus we'll have to deal with either CmmProc ...+cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do+  picBaseMb <- getPicBaseMaybeNat+  when (isJust picBaseMb) $ panic "LA64.cmmTopCodeGen: Unexpected PIC base register"++  let blocks = toBlockListEntryFirst graph+  (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks++  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics++  pure tops++-- ... or CmmData.+cmmTopCodeGen (CmmData sec dat) = pure [CmmData sec dat] -- no translation, we just use CmmStatic++basicBlockCodeGen ::+  Block CmmNode C C ->+  NatM+    ( [NatBasicBlock Instr],+      [NatCmmDecl RawCmmStatics Instr]+    )+basicBlockCodeGen block = do+  config <- getConfig+  let (_, nodes, tail) = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes++      header_comment_instr+        | debugIsOn =+            unitOL+              $ MULTILINE_COMMENT+                ( text "-- --------------------------- basicBlockCodeGen --------------------------- --\n"+                    $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block)+                )+        | otherwise = nilOL++  -- Generate location directive `.loc` (DWARF debug location info)+  loc_instrs <- genLocInstrs++  -- Generate other instructions+  mid_instrs <- stmtsToInstrs stmts+  (!tail_instrs) <- stmtToInstrs tail++  let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs++      -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to+      -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs+      -- work fine without it.++      -- Code generation may introduce new basic block boundaries, which are+      -- indicated by the NEWBLOCK instruction. We must split up the instruction+      -- stream into basic blocks again. Also, we extract LDATAs here too.+      (top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs++  return (BasicBlock id top : other_blocks, statics)+  where+    genLocInstrs :: NatM (OrdList Instr)+    genLocInstrs = do+      dbg <- getDebugBlock (entryLabel block)+      case dblSourceTick =<< dbg of+        Just (SourceNote span name) ->+          do+            fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            pure $ unitOL $ LOCATION fileId line col name+        _ -> pure nilOL++mkBlocks ::+  Instr ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])+mkBlocks (NEWBLOCK id) (instrs, blocks, statics) =+  ([], BasicBlock id instrs : blocks, statics)+mkBlocks (LDATA sec dat) (instrs, blocks, statics) =+  (instrs, blocks, CmmData sec dat : statics)+mkBlocks instr (instrs, blocks, statics) =+  (instr : instrs, blocks, statics)++-- -----------------------------------------------------------------------------+-- | Utilities++-- | Annotate an `Instr` with a `SDoc` comment+ann :: SDoc -> Instr -> Instr+ann doc instr {- debugIsOn -} = ANN doc instr+{-# INLINE ann #-}++-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with+-- -dppr-debug.  The idea is that we can trivially see how a cmm expression+-- ended up producing the assembly we see.  By having the verbatim AST printed+-- we can simply check the patterns that were matched to arrive at the assembly+-- we generated.+--+-- pprExpr will hide a lot of noise of the underlying data structure and print+-- the expression into something that can be easily read by a human. However+-- going back to the exact CmmExpr representation can be laborious and adds+-- indirections to find the matches that lead to the assembly.+--+-- An improvement oculd be to have+--+--    (pprExpr genericPlatform e) <> parens (text. show e)+--+-- to have the best of both worlds.+--+-- Note: debugIsOn is too restrictive, it only works for debug compilers.+-- However, we do not only want to inspect this for debug compilers. Ideally+-- we'd have a check for -dppr-debug here already, such that we don't even+-- generate the ANN expressions. However, as they are lazy, they shouldn't be+-- forced until we actually force them, and without -dppr-debug they should+-- never end up being forced.+annExpr :: CmmExpr -> Instr -> Instr+annExpr e {- debugIsOn -} = ANN (text . show $ e)+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr+-- annExpr _ instr = instr+{-# INLINE annExpr #-}++-- -----------------------------------------------------------------------------+-- Generating a table-branch+-- The index into the jump table is calulated by evaluating @expr@. The+-- corresponding table entry contains the address to jump to.+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch config expr targets = do+  (reg, fmt1, e_code) <- getSomeReg indexExpr+  targetReg <- getNewRegNat II64+  lbl <- getNewLabelNat+  dynRef <- cmmMakeDynamicReference config DataReference lbl+  (tableReg, fmt2, t_code) <- getSomeReg $ dynRef+  let code =+        toOL [ COMMENT (text "indexExpr" <+> (text . show) indexExpr)+             , COMMENT (text "dynRef" <+> (text . show) dynRef)+             ]+          `appOL` e_code+          `appOL` t_code+          `appOL` toOL+            [+              COMMENT (ftext "Jump table for switch"),+              -- index to offset into the table (relative to tableReg)+              annExpr expr (SLL (OpReg W64 reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))),+              -- calculate table entry address+              ADD (OpReg W64 targetReg) (OpReg W64 reg) (OpReg (formatToWidth fmt2) tableReg),+              -- load table entry (relative offset from tableReg (first entry) to target label)+              LDU II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))),+              -- calculate absolute address of the target label+              ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg),+              -- prepare jump to target label+              J_TBL bids (Just lbl) targetReg+            ]+  return code+  where+    platform = ncgPlatform config+    expr_w = cmmExprWidth platform expr+    indexExpr0 = cmmOffset platform expr offset+    -- Widen to a native-width register(addressing modes)+    indexExpr = CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+    (offset, bids) = switchTargetsToTable targets+++-- Generate jump table data (if required)+--+-- Relies on PIC relocations. The idea is to emit one table entry per case. The+-- entry is the label of the block to jump to. This will be relocated to be the+-- address of the jump target.+generateJumpTableForInstr ::+  NCGConfig ->+  Instr ->+  Maybe (NatCmmDecl RawCmmStatics Instr)+generateJumpTableForInstr config (J_TBL ids (Just lbl) _) =+  let jumpTable =+        map jumpTableEntryRel ids+        where+          jumpTableEntryRel Nothing =+            CmmStaticLit (CmmInt 0 (ncgWordWidth config))+          jumpTableEntryRel (Just blockid) =+            CmmStaticLit+              ( CmmLabelDiffOff+                  blockLabel+                  lbl+                  0+                  (ncgWordWidth config)+              )+            where+              blockLabel = blockLbl blockid+   in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable))+generateJumpTableForInstr _ _ = Nothing++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector+stmtsToInstrs ::+  -- | Cmm Statements+  [CmmNode O O] ->+  -- | Resulting instruction+  NatM InstrBlock+stmtsToInstrs stmts = concatOL <$> mapM stmtToInstrs stmts++stmtToInstrs ::+  CmmNode e x ->+  -- | Resulting instructions+  NatM InstrBlock++stmtToInstrs stmt = do+  config <- getConfig+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+      -> genCCall target result_regs args++    CmmComment s   -> return (unitOL (COMMENT (ftext s)))+    CmmTick {}     -> return nilOL++    CmmAssign reg src+      | isFloatType ty         -> assignReg_FltCode format reg src+      | otherwise              -> assignReg_IntCode format reg src+        where ty = cmmRegType reg+              format = cmmTypeFormat ty++    CmmStore addr src _alignment+      | isFloatType ty         -> assignMem_FltCode format addr src+      | otherwise              -> assignMem_IntCode format addr src+        where ty = cmmExprType platform src+              format = cmmTypeFormat ty++    CmmBranch id          -> genBranch id++    --We try to arrange blocks such that the likely branch is the fallthrough+    --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+    CmmCondBranch arg true false _prediction ->+        genCondBranch true false arg++    CmmSwitch arg ids -> genSwitch config arg ids++    CmmCall { cml_target = arg } -> genJump arg++    CmmUnwind _regs -> pure nilOL++    _ ->  pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)++-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--  They are really trees of insns to facilitate fast appending, where a+--  left-to-right traversal yields the insns in the correct order.+type InstrBlock =+  OrdList Instr++-- | Register's passed up the tree.+--  If the stix code forces the register to live in a pre-decided machine+--  register, it comes out as @Fixed@; otherwise, it comes out as @Any@, and the+--  parent can decide which register to put it in.+data Register+  = Fixed Format Reg InstrBlock+  | Any Format (Reg -> InstrBlock)++-- | Sometimes we need to change the Format of a register. Primarily during+--  conversion.+swizzleRegisterRep :: Format -> Register -> Register+swizzleRegisterRep format' (Fixed _ reg code) = Fixed format' reg code+swizzleRegisterRep format' (Any _ codefn) = Any format' codefn++-- | Grab a `Reg` for a `CmmReg`+getRegisterReg :: Platform -> CmmReg -> Reg++getRegisterReg _ (CmmLocal (LocalReg u pk))+  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)++getRegisterReg platform (CmmGlobal mid)+  = case globalRegMaybe platform (globalRegUse_reg mid) of+        Just reg -> RegReal reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)++-- General things for putting together code sequences++-- | Compute an expression into any register+getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, rep, code tmp)+    Fixed rep reg code ->+        return (reg, rep, code)++-- | Compute an expression into any floating-point register++-- | Compute an expression into floating point register+--  If the initial expression is not a floating-point expression, finally move+--  the result into a floating-point register.+getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg expr = do+  r <- getRegister expr+  case r of+    Any rep code | isFloatFormat rep -> do+      tmp <- getNewRegNat rep+      return (tmp, rep, code tmp)+    Any II32 code -> do+      tmp <- getNewRegNat FF32+      return (tmp, FF32, code tmp)+    Any II64 code -> do+      tmp <- getNewRegNat FF64+      return (tmp, FF64, code tmp)+    Any _w _code -> do+      config <- getConfig+      pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)+    -- can't do much for fixed.+    Fixed rep reg code ->+      return (reg, rep, code)++-- | Map `CmmLit` to `OpImm`+litToImm' :: CmmLit -> Operand+litToImm' = OpImm . litToImm++-- Handling PIC on LA64+-- Commonly, `PIC` means of `position independent code`, that to say, the execution+-- of code does not be influenced by Load_address. Through PC-Relative addressing+-- or GOT addressing, both can be used to implement `PIC`.+--+-- For LoongArch's common compiler(GCC, Clang), they generate PIC code by default+-- without condition. The command option `-fPIC` dicates to generate code for+-- shared-library. If not just specified for shared-library, another option `-fPIE`+-- was be created.+--+-- Like RV64, LA64 does not have a special PIC register, the general approach is to+-- simply do PC-relative addressing or go through the GOT. There is assembly support+-- for both.+--+-- LA64 assembly has many `la*` (load address) pseudo-instructions, that allows+-- loading a symbols's address into a register. These instructions is desugared into+-- different addressing modes. See following:+--+-- la        rd, label + addend  -> Load global symbol+-- la.global rd, label + addend  -> Same as `la`+-- la.local  rd, label + addend  -> Load local symbol+-- la.pcrel  rd, label + addend+-- la.got    rd, label+-- la.abs    rd, label + addend+--+-- `la` is alias of `la.global`. Commonly recommended use `la.local` and `la.global`.+--+-- PC-relative addressing:+--   pcalau12i $a0, %pc_hi20(a)+--   addi.d    $a0, $a0, %pc_lo12(a)+--+-- GOT addressing:+--   pcalau12i $a0, %got_pc_hi20(global_a)+--   ld.d      $a0, $a0, %got_pc_lo12(global_a)+--+-- PIC can be enabled/disabled through:+--  .option pic+--+-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the+-- @cmmMakePicReference@.  This is in turn called from @cmmMakeDynamicReference@+-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported.  There are two+-- callsites for this. One is in this module to produce the @target@ in @genCCall@+-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@.+--+-- Conceptually we do not want any special PicBaseReg to be used on LA64. If+-- we want to distinguish between symbol loading, we need to address this through+-- the way we load it, not through a register.++-- Compute a `CmmExpr` into a `Register`+getRegister :: CmmExpr -> NatM Register+getRegister e = do+  config <- getConfig+  getRegister' config (ncgPlatform config) e++-- Signed arithmetic on LoongArch64+--+-- Handling signed arithmetic on sub-word-size values on LA64 is a bit tricky+-- as Cmm's type system does not capture signedness. While 32- and 64-bit+-- values are fairly easy to handle due to LA64's 32- and 64-bit instructions+-- with responding register, 8- and 16-bit values require quite some care.+--+-- For LoongArch64, EXT.W.[B/H] will sign-extend 8- and 16-bit to 64-bit.+-- However, it is best to use EXT instruction only if the input and+-- output data widths are fully determined.+--+-- We handle 16-and 8-bit values by using the following two steps:+--  1. Sign- or Zero-extending operands.+--  2. Truncate results as necessary.+--+-- For simplicity we maintain the invariant that a register containing a+-- sub-word-size value always contains the zero-extended form of that value+-- in between operations.++getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register++-- OPTIMIZATION WARNING: CmmExpr rewrites++-- Generic case.+getRegister' config plat expr =+  case expr of+    CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) ->+      pprPanic "getRegisterReg-memory" (ppr PicBaseReg)++    CmmLit lit ->+      case lit of+        CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL+        CmmInt i w -> do+          -- narrowU is important: Negative immediates may be+          -- sign-extended on load!+          let imm = OpImm . ImmInteger $ narrowU w i+          return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) imm)))++        CmmFloat 0 w -> do+          let op = litToImm' lit+          pure (Any (floatFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) op)))++        CmmFloat _f W8  -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr)+        CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr)++        CmmFloat f W32 -> do+          let word = castFloatToWord32 (fromRational f) :: Word32+          tmp <- getNewRegNat (intFormat W32)+          return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W32 tmp) (OpImm (ImmInteger (fromIntegral word)))+                                                      , MOV (OpReg W32 dst) (OpReg W32 tmp)+                                                      ]))+        CmmFloat f W64 -> do+          let word = castDoubleToWord64 (fromRational f) :: Word64+          tmp <- getNewRegNat (intFormat W64)+          return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W64 tmp) (OpImm (ImmInteger (fromIntegral word)))+                                                      , MOV (OpReg W64 dst) (OpReg W64 tmp)+                                                      ]))++        CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr)+        CmmVec _lits -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr)++        CmmLabel lbl -> do+          let op = OpImm (ImmCLbl lbl)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ annExpr expr (LD format (OpReg (formatToWidth format) dst) op)))++        CmmLabelOff lbl off | isNbitEncodeable 12 (fromIntegral off) -> do+          let op = OpImm (ImmIndex lbl off)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ LD format (OpReg (formatToWidth format) dst) op))++        CmmLabelOff lbl off -> do+          let op = litToImm' (CmmLabel lbl)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+              width = typeWidth rep+          (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)+          return (Any format (\dst -> off_code `snocOL`+                                                LD format (OpReg (formatToWidth format) dst) op `snocOL`+                                                ADD (OpReg W64 dst) (OpReg width dst) (OpReg width off_r)+                             ))++        CmmLabelDiffOff {} -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)++    CmmLoad mem rep _ -> do+      let format = cmmTypeFormat rep+          width = typeWidth rep+      Amode addr addr_code <- getAmode plat width mem+      case width of+        w | w `elem` [W8, W16, W32, W64] ->+            -- Load without sign-extension.+            pure (Any format (\dst ->+              addr_code `snocOL`+              LDU format (OpReg width dst) (OpAddr addr))+                              )+        _ -> pprPanic ("Unknown width to load: " ++ show width) (pdoc plat expr)++    CmmStackSlot _ _  -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr)++    CmmReg reg -> return (Fixed (cmmTypeFormat (cmmRegType reg))+                                (getRegisterReg plat reg)+                                nilOL+                         )++    CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do+      getRegister' config plat+        $ CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+      where+        width = typeWidth (cmmRegType reg)+    CmmRegOff reg off -> do+      (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)+      (reg, _format, code) <- getSomeReg $ CmmReg reg+      return $ Any (intFormat width) ( \dst ->+                                        off_code `appOL`+                                        code `snocOL`+                                        ADD (OpReg W64 dst) (OpReg width reg) (OpReg width off_r)+                                     )+      where+        width = typeWidth (cmmRegType reg)++    -- Handle MO_RelaxedRead as a normal CmmLoad, to allow+    -- non-trivial addressing modes to be used.+    CmmMachOp (MO_RelaxedRead w) [e] ->+      getRegister (CmmLoad e (cmmBits w) NaturallyAligned)++    -- for MachOps, see GHC.Cmm.MachOp+    -- For CmmMachOp, see GHC.Cmm.Expr+    CmmMachOp op [e] -> do+      (reg, format, code) <- getSomeReg e+      case op of+        MO_Not w -> return $ Any (intFormat w) $ \dst ->+          code `appOL`+          -- pseudo instruction `not dst rd` is `nor dst, r0, rd`+          truncateReg (formatToWidth format) W64 reg `snocOL`+          -- At this point an 8- or 16-bit value would be zero-extended+          -- to 64-bits. Truncate back down the final width.+          ann (text "not") (NOR (OpReg W64 dst) (OpReg W64 reg) zero) `appOL`+          truncateReg W64 w dst++        MO_S_Neg w -> negate code w reg+        MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` FNEG (OpReg w dst) (OpReg w reg))++        -- Floating convertion oprations+        -- Float -> Float+        MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg))++        -- Signed int -> Float+        MO_SF_Round from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))++        -- Float -> Signed int+        MO_FS_Truncate from to | from == W32 -> do+            tmp <- getNewRegNat FF32+            return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg))++        MO_FS_Truncate from to | from == W64-> do+            tmp <- getNewRegNat FF64+            return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg))++        -- unsigned int -> unsigned int+        MO_UU_Conv from to -> return $ Any (intFormat to) (\dst ->+          code `snocOL` BSTRPICK II64 (OpReg W64 dst) (OpReg W64 reg) (OpImm (ImmInt (widthToInt (min from to) - 1))) (OpImm (ImmInt 0))+                                                          )++        -- Signed int -> Signed int+        MO_SS_Conv from to -> ss_conv from to reg code++        -- int -> int+        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e++        MO_WF_Bitcast w    -> return $ Any (floatFormat w)  (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))+        MO_FW_Bitcast w    -> return $ Any (intFormat w)    (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))++        x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr)+      where+        -- In the case of 32- or 16- or 8-bit values we need to sign-extend to 64-bits+        negate code w reg+          | w `elem` [W8, W16] = do+            return $ Any (intFormat w) $ \dst ->+                code `snocOL`+                EXT (OpReg W64 reg) (OpReg w reg) `snocOL`+                NEG (OpReg W64 dst) (OpReg W64 reg) `appOL`+                truncateReg W64 w dst+          | otherwise = do+            return $ Any (intFormat w) $ \dst ->+                code `snocOL`+                NEG (OpReg W64 dst) (OpReg w reg)++        ss_conv from to reg code+          | from `elem` [W8, W16] || to `elem` [W8, W16] = do+            return $ Any (intFormat to) $ \dst ->+                code `snocOL`+                EXT (OpReg W64 dst) (OpReg (min from to) reg) `appOL`+                -- At this point an 8- or 16-bit value would be sign-extended+                -- to 64-bits. Truncate back down the final width.+                truncateReg W64 to dst+          | from == W32 && to == W64 = do+            return $ Any (intFormat to) $ \dst ->+                code `snocOL`+                SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt 0))+          | from == to = do+            return $ Any (intFormat from) $ \dst ->+                 code `snocOL` MOV (OpReg from dst) (OpReg from reg)+          | otherwise = do+            return $ Any (intFormat to) $ \dst ->+                code `appOL`+                signExtend from W64 reg dst `appOL`+                truncateReg W64 to dst+++-- Dyadic machops:+    --+    -- The general idea is:+    -- compute x<i> <- x+    -- compute x<j> <- y+    -- OP x<r>, x<i>, x<j>+    --+    -- TODO: for now we'll only implement the 64bit versions. And rely on the+    --      fallthrough to alert us if things go wrong!+    -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring+    -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg+    CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'+    CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'++    CmmMachOp (MO_Add w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do+      if w `elem` [W8, W16]+        then do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        ADD (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                     )+        else do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ADD (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_Sub w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do+      if w `elem` [W8, W16]+        then do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        SUB (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                     )+        else do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SUB (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_U_Quot w) [x, y]+      | w `elem` [W8, W16] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) (\dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (DIVU (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    -- 2. Shifts.+    CmmMachOp (MO_Shl w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                     )+        CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        _ | w `elem` [W8, W16] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL`+                                        SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)+                                     )+        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- MO_S_Shr: signed-shift-right+    CmmMachOp (MO_S_Shr w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w)  (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                      )+        CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        _ | w `elem` [W8, W16] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL`+                                        SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)+                                     )+        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- MO_U_Shr: unsigned-shift-right+    CmmMachOp (MO_U_Shr w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )+        CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        _ | w `elem` [W8, W16] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )+        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- 3. Logic &&, ||+    -- andi Instr's Imm-operand is zero-extended.+    CmmMachOp (MO_And w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )++        CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                       code_x `appOL`+                                       truncateReg w W64 reg_x `snocOL`+                                       annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`+                                       AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        CmmLit (CmmInt n _) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger  n))) `snocOL`+                                        AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        _ | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- ori Instr's Imm-operand is zero-extended.+    CmmMachOp (MO_Or w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )++        CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                       code_x `appOL`+                                       truncateReg w W64 reg_x `snocOL`+                                       annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`+                                       OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        CmmLit (CmmInt n _) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger  n))) `snocOL`+                                        OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        _ | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- xori Instr's Imm-operand is zero-extended.+    CmmMachOp (MO_Xor w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )++        CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (XOR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                       code_x `appOL`+                                       truncateReg w W64 reg_x `snocOL`+                                       annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`+                                       XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        CmmLit (CmmInt n _) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger  n))) `snocOL`+                                        XOR (OpReg W64 dst) (OpReg w reg_x) (OpReg W64 tmp)+                                     )++        _ | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++    -- CSET commands register operand being W64.+    CmmMachOp (MO_Eq w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+       | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_Ne w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Lt w) [x, CmmLit (CmmInt n _)]+      | w `elem` [W8, W16, W32]+      , fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      signExtend w W64 reg_x reg_x `snocOL`+                                      annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                   )+      | fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_U_Lt w) [x, CmmLit (CmmInt n _)]+      | w `elem` [W8, W16, W32]+      , fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      truncateReg w W64 reg_x `snocOL`+                                      annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                   )+      | fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger  n))))++    CmmMachOp (MO_S_Lt w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Le w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Ge w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Gt w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Lt w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Le w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Ge w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Gt w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+++    -- Generic binary case.+    CmmMachOp op [x, y] -> do+      let+          -- A (potentially signed) integer operation.+          -- In the case of 8-, 16- and 32-bit signed arithmetic we must first+          -- sign-extend all arguments to 64-bits.+          -- TODO: can be simplified.+          intOp is_signed w op = do+              -- compute x<m> <- x+              -- compute x<o> <- y+              -- <OP> x<n>, x<m>, x<o>+              (reg_x, format_x, code_x) <- getSomeReg x+              (reg_y, format_y, code_y) <- getSomeReg y+              massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"+              let w' = W64+              -- This is the width of the registers on which the operation+              -- should be performed.+              if not is_signed+                then return $ Any (intFormat w) $ \dst ->+                      code_x `appOL`+                      code_y `appOL`+                      -- zero-extend both operands+                      truncateReg (formatToWidth format_x) w' reg_x `appOL`+                      truncateReg (formatToWidth format_y) w' reg_y `snocOL`+                      op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+                      truncateReg w' w dst -- truncate back to the operand's original width+                else return $ Any (intFormat w) $ \dst ->+                      code_x `appOL`+                      code_y `appOL`+                      -- sign-extend both operands+                      signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`+                      signExtend (formatToWidth format_x) W64 reg_y reg_y `snocOL`+                      op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+                      truncateReg w' w dst -- truncate back to the operand's original width++          floatOp w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float"+            return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))++          -- need a special one for conditionals, as they return ints+          floatCond w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float"+            return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))++      case op of+        -- Integer operations+        -- Add/Sub should only be Integer Options.+        MO_Add w -> intOp False w (\d x y ->  annExpr expr (ADD d x y))+        MO_Sub w -> intOp False w (\d x y ->  annExpr expr (SUB d x y))++        -- Signed multiply/divide/remain+        MO_Mul w          -> intOp True w (\d x y -> annExpr expr (MUL d x y))+        MO_S_MulMayOflo w -> do_mul_may_oflo w x y++        MO_S_Quot w  -> intOp True w (\d x y -> annExpr expr (DIV d x y))+        MO_S_Rem w   -> intOp True w (\d x y -> annExpr expr (MOD d x y))++        -- Unsigned divide/remain+        MO_U_Quot w  -> intOp False w (\d x y -> annExpr expr (DIVU d x y))+        MO_U_Rem w   -> intOp False w (\d x y -> annExpr expr (MODU d x y))++        -- Floating point arithmetic+        MO_F_Add w   -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))+        MO_F_Sub w   -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))+        MO_F_Mul w   -> floatOp w (\d x y -> unitOL $ annExpr expr (MUL d x y))+        MO_F_Quot w  -> floatOp w (\d x y -> unitOL $ annExpr expr (DIV d x y))+        MO_F_Min w   -> floatOp w (\d x y -> unitOL $ annExpr expr (FMIN d x y))+        MO_F_Max w   -> floatOp w (\d x y -> unitOL $ annExpr expr (FMAX d x y))++        -- Floating point comparison+        MO_F_Eq w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET EQ d x y))+        MO_F_Ne w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET NE d x y))+        MO_F_Ge w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGE d x y))+        MO_F_Le w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLE d x y))+        MO_F_Gt w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGT d x y))+        MO_F_Lt w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLT d x y))++        op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr++    -- Generic ternary case.+    CmmMachOp op [x, y, z] ->+      case op of++        -- Floating-point fused multiply-add operations+        MO_FMA var l w+          | l == 1+          -> case var of+            FMAdd  -> float3Op w (\d n m a -> unitOL $ FMA FMAdd  d n m a)+            FMSub  -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a)+            FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FNMSub  d n m a)+            FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)+          | otherwise+          -> sorry "The RISCV64 backend does not (yet) support vectors."++        _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr)++      where+          float3Op w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            (reg_fz, format_z, code_fz) <- getFloatReg z+            massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $+              text "float3Op: non-float"+            pure $+              Any (floatFormat w) $ \ dst ->+                code_fx `appOL`+                code_fy `appOL`+                code_fz `appOL`+                op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz)++    CmmMachOp _op _xs+      -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)++  where+    -- N.B. MUL does not set the overflow flag.+    -- Return 0 when the operation cannot overflow, /= 0 otherwise+    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    do_mul_may_oflo W64 x y = do+      (reg_x, _format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      lo <- getNewRegNat II64+      hi <- getNewRegNat II64+      return $ Any (intFormat W64) (\dst ->+        code_x `appOL`+        code_y `snocOL`+        MULH (OpReg W64 hi) (OpReg W64 reg_x)  (OpReg W64 reg_y) `snocOL`+        MUL  (OpReg W64 lo) (OpReg W64 reg_x)  (OpReg W64 reg_y) `snocOL`+        SRA  (OpReg W64 lo) (OpReg W64 lo)     (OpImm (ImmInt 63)) `snocOL`+        CSET NE (OpReg W64 dst) (OpReg W64 hi)  (OpReg W64 lo)+                                 )++    do_mul_may_oflo W32 x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        tmp1 <- getNewRegNat II64+        tmp2 <- getNewRegNat II64+        return $ Any (intFormat W32) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            MULW (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL`+            ADD (OpReg W64 tmp2) (OpReg W32 tmp1) (OpImm (ImmInt 0)) `snocOL`+            CSET NE (OpReg W64 dst) (OpReg W64 tmp1)  (OpReg W64 tmp2)+                                     )++    -- General case+    do_mul_may_oflo w x y = do+      -- Assert: 8bit * 8bit cannot overflow 16bit, and so on.+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, format_y, code_y) <- getSomeReg y+      tmp1 <- getNewRegNat II64+      tmp2 <- getNewRegNat II64+      let width_x = formatToWidth format_x+          width_y = formatToWidth format_y+          extend dst src =+            case w of+              W8  -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0))+              W16 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0))+              _   -> panic "Must be in [W8, W16, W32]!"+          extract width dst src =+            case width of+              W8  -> EXT (OpReg W64 dst) (OpReg W8 src)+              W16 -> EXT (OpReg W64 dst) (OpReg W16 src)+              W32 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0))+              _   -> panic "Must be in [W8, W16, W32]!"++      case w of+        w | (width_x < w) && (width_y < w) ->+          return $ Any (intFormat w) ( \dst ->+            unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 0)))+                                     )+        w | w <= W32 && width_x <= W32 && width_y <= W32 ->+            return $ Any (intFormat W32) (\dst ->+                code_x `appOL`+                code_y `appOL`+                -- signExtend [W8, W16] register to W64 and then SLL+                -- nil for W32+                signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`+                signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`+                extend reg_x reg_x `snocOL`+                extend reg_y reg_y `snocOL`+                -- 64-bits MUL+                MUL (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL`+                -- extract valid result via result's width+                -- slli.w for W32, otherwise ext.w.[b, h]+                extract w tmp2 tmp1 `snocOL`+                CSET NE (OpReg W64 dst) (OpReg W64 tmp1)  (OpReg W64 tmp2)+                                        )++        -- Should it be happened?+        _ ->+          return $ Any (intFormat w) ( \dst ->+            unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 1))))++-- Sign-extend the value in the given register from width @w@+-- up to width @w'@.+-- TODO: Is there room for optimization?+signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr+signExtend w w' r r'+  | w > w' = pprPanic "Sign-extend Error: not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w'+  | w > W64 || w' > W64  = pprPanic "Sign-extend Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w'+  | w == W64 && w' == W64 && r == r' = nilOL+  | w == W32 && w' == W64 = unitOL $ SLL (OpReg W64 r') (OpReg w r) (OpImm (ImmInt 0))+  -- Sign-extend W8 and W16 to W64.+  | w `elem` [W8, W16] = unitOL $ EXT (OpReg W64 r') (OpReg w r)+  | w == w' = unitOL $ MOV (OpReg w' r') (OpReg w r)+  | otherwise = pprPanic "signExtend: Unexpected width: " $ ppr w  <> text "->" <+> ppr w'++-- | Instructions to truncate the value in the given register from width @w@+-- down to width @w'@.+truncateReg :: Width -> Width -> Reg -> OrdList Instr+truncateReg w w' r+  | w > W64 || w' > W64  = pprPanic "Tructate Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w'+  | w == w' = nilOL+  | w /= w' = toOL+    [+      ann+        (text "truncateReg: " <+> ppr r <+> ppr w <> text "->" <> ppr w')+        (BSTRPICK II64 (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift)) (OpImm (ImmInt 0)))+    ]+  | otherwise = pprPanic "truncateReg: Unexpected width: " $ ppr w  <> text "->" <+> ppr w'+  where+    shift = (min (widthInBits w) (widthInBits w')) - 1++--  The 'Amode' type: Memory addressing modes passed up the tree.+data Amode = Amode AddrMode InstrBlock++-- | Provide the value of a `CmmExpr` with an `Amode`+--  N.B. this function should be used to provide operands to load and store+--  instructions with signed 12bit wide immediates (S & I types). For other+--  immediate sizes and formats (e.g. B type uses multiples of 2) this function+--  would need to be adjusted.+getAmode :: Platform+         -> Width     -- ^ width of loaded value+         -> CmmExpr+         -> NatM Amode++-- LD/ST: Immediate can be represented with 12bits+getAmode platform w (CmmRegOff reg off)+  | w <= W64, fitsInNbits 12 (fromIntegral off)+  = return $ Amode (AddrRegImm reg' off') nilOL+    where reg' = getRegisterReg platform reg+          off' = ImmInt off++-- For Stores we often see something like this:+-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2)+-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ]+-- for `n` in range.+getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])+  | fitsInNbits 12 (fromIntegral off)+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger off)) code++getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+  | fitsInNbits 12 (fromIntegral (-off))+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger (-off))) code++-- Generic case+getAmode _platform _ expr+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrReg reg) code++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_IntCode rep addrE srcE+  = do+    (src_reg, _format, code) <- getSomeReg srcE+    platform <- getPlatform+    let w = formatToWidth rep+    Amode addr addr_code <- getAmode platform w addrE+    return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE)))+            `consOL` (code+            `appOL`   addr_code+            `snocOL`  ST rep (OpReg w src_reg) (OpAddr addr)+                     )++assignReg_IntCode _ reg src+  = do+    platform <- getPlatform+    let dst = getRegisterReg platform reg+    r <- getRegister src+    return $ case r of+      Any _ code              -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst+      Fixed format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL`+                                               (fcode `snocOL`+                                                 MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg)+                                               )++-- Let's treat Floating point stuff+-- as integer code for now. Opaque.+assignMem_FltCode = assignMem_IntCode+assignReg_FltCode = assignReg_IntCode++-- Jumps+genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock+genJump expr = do+  case expr of+    (CmmLit (CmmLabel lbl)) -> do+      return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TLabel lbl)))+    (CmmLit (CmmBlock bid)) -> do+      return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TBlock bid)))+    _ -> do+      (target, _format, code) <- getSomeReg expr+      -- I'd like to do more.+      return $ COMMENT (text "genJump for unknow expr: " <+> (text (show expr))) `consOL`+        (code `appOL`+          unitOL (annExpr expr (J (TReg target)))+        )++-- -----------------------------------------------------------------------------+--  Unconditional branches+genBranch :: BlockId -> NatM InstrBlock+genBranch = return . toOL . mkJumpInstr++-- -----------------------------------------------------------------------------+-- Conditional branches+genCondJump+    :: BlockId+    -> CmmExpr+    -> NatM InstrBlock+genCondJump bid expr = do+    case expr of+      -- Optimized == 0 case.+      CmmMachOp (MO_Eq W64) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $+          code_x `snocOL`+          BEQZ (OpReg W64 reg_x) (TBlock bid)+      CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)]+        | w `elem` [W8, W16, W32] -> do+        (reg_x, format_x, code_x) <- getSomeReg x+        return $+          code_x `appOL`+          signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`+          BEQZ (OpReg W64 reg_x) (TBlock bid)++      -- Optimized /= 0 case.+      CmmMachOp (MO_Ne W64) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ code_x `snocOL` (annExpr expr (BNEZ (OpReg W64 reg_x) (TBlock bid)))+      CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)]+        | w `elem` [W8, W16, W32] -> do+        (reg_x, format_x, code_x) <- getSomeReg x+        return $+          code_x `appOL`+          signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`+          BNEZ (OpReg W64 reg_x) (TBlock bid)++      -- Generic case.+      CmmMachOp mop [x, y] -> do+        let ubcond w cmp = do+              (reg_x, format_x, code_x) <- getSomeReg x+              (reg_y, format_y, code_y) <- getSomeReg y+              return $ case w of+                w | w `elem` [W8, W16, W32] ->+                    code_x `appOL`+                    truncateReg (formatToWidth format_x) W64 reg_x  `appOL`+                    code_y `appOL`+                    truncateReg (formatToWidth format_y) W64 reg_y  `snocOL`+                    BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)+                _ ->+                    code_x `appOL`+                    code_y `snocOL`+                    BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)++            sbcond w cmp = do+              (reg_x, format_x, code_x) <- getSomeReg x+              (reg_y, format_y, code_y) <- getSomeReg y+              return $ case w of+                w | w `elem` [W8, W16, W32] ->+                  code_x `appOL`+                  signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`+                  code_y `appOL`+                  signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`+                  BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)+                _ ->+                  code_x `appOL`+                  code_y `snocOL`+                  BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)++            fbcond w cmp = do+              (reg_fx, _format_fx, code_fx) <- getFloatReg x+              (reg_fy, _format_fy, code_fy) <- getFloatReg y+              rst <- OpReg W64 <$> getNewRegNat II64+              oneReg <- OpReg W64 <$> getNewRegNat II64+              return $+                code_fx `appOL`+                code_fy `snocOL`+                CSET cmp rst (OpReg w reg_fx) (OpReg w reg_fy) `snocOL`+                MOV oneReg (OpImm (ImmInt 1)) `snocOL`+                BCOND1 EQ rst oneReg (TBlock bid)+++        case mop of+          MO_F_Eq w -> fbcond w EQ+          MO_F_Ne w -> fbcond w NE+          MO_F_Gt w -> fbcond w FGT+          MO_F_Ge w -> fbcond w FGE+          MO_F_Lt w -> fbcond w FLT+          MO_F_Le w -> fbcond w FLE+          MO_Eq w   -> sbcond w EQ+          MO_Ne w   -> sbcond w NE+          MO_S_Gt w -> sbcond w SGT+          MO_S_Ge w -> sbcond w SGE+          MO_S_Lt w -> sbcond w SLT+          MO_S_Le w -> sbcond w SLE+          MO_U_Gt w -> ubcond w UGT+          MO_U_Ge w -> ubcond w UGE+          MO_U_Lt w -> ubcond w ULT+          MO_U_Le w -> ubcond w ULE+          _ -> pprPanic "LA64.genCondJump:case mop: " (text $ show expr)++      _ -> pprPanic "LA64.genCondJump: " (text $ show expr)++-- | Generate conditional branching instructions+-- This is basically an "if with else" statement.+genCondBranch ::+  BlockId ->+  BlockId ->+  CmmExpr ->+  NatM InstrBlock+genCondBranch true false expr = do+  b1 <- genCondJump true expr+  b2 <- genBranch false+  return (b1 `appOL` b2)++-- -----------------------------------------------------------------------------+{-+Generating C calls++Generate a call to a C function:++GARs: 8 general-purpose registers $a0 - $a7, where $a0 and $a1 are also used for+integral values.+FARs: 8 floating-point registers $fa0 - $fa7, where $fa0 and $fa1 are also used+for returning values.++An argument is passed using the stack only when no appropriate argument register+is available.++Subroutines should ensure that the initial values of the general-purpose registers+$s0 - $s9 and floating-point registers $fs0 - $fs7 are preserved across the call.++At the entry of a procedure call, the return address of the call site is stored+in $ra. A branch jump to this address should be the last instruction executed in+the called procedure.++The on-stack part of the structure and scalar arguments are aligned to the greater+of the type alignment and GRLEN bits, except when this alignment is larger than+ the 16-byte stack alignment. In this case, the part of the argument should be+16-byte-aligned.++In a procedure call, GARs / FARs are generally only used for passing non-floating+-point / floating-point argument data, respectively. However, the floating-point+member of a structure or union argument, or a vector/floating-point argument+wider than FRLEN may be passed in a GAR.+-}++genCCall+    :: ForeignTarget      -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> NatM InstrBlock++-- TODO: Specialize where we can.+-- Generic impl+genCCall target dest_regs arg_regs = do+  case target of+    -- The target :: ForeignTarget call can either+    -- be a foreign procedure with an address expr+    -- and a calling convention.+    ForeignTarget expr _cconv -> do+      (call_target, call_target_code) <- case expr of+        -- if this is a label, let's just directly to it.+        (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)+        -- if it's not a label, let's compute the expression into a+        -- register and jump to that.+        _ -> do+          (reg, _format, reg_code) <- getSomeReg expr+          pure (TReg reg, reg_code)+      -- compute the code and register logic for all arg_regs.+      -- this will give us the format information to match on.+      arg_regs' <- mapM getSomeReg arg_regs++      -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes+      -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in+      -- STG; this thenn breaks packing of stack arguments, if we need to pack+      -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type+      -- in Cmm proper. Option two, which we choose here is to use extended Hint+      -- information to contain the size information and use that when packing+      -- arguments, spilled onto the stack.+      let (_res_hints, arg_hints) = foreignTargetHints target+          arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints++      (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL++      readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL++      let moveStackDown 0 = toOL [ PUSH_STACK_FRAME+                                 , DELTA (-16)+                                 ]+          moveStackDown i | odd i = moveStackDown (i + 1)+          moveStackDown i = toOL [ PUSH_STACK_FRAME+                                 , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))+                                 , DELTA (-8 * i - 16)+                                 ]+          moveStackUp 0 = toOL [ POP_STACK_FRAME+                               , DELTA 0+                               ]+          moveStackUp i | odd i = moveStackUp (i + 1)+          moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))+                               , POP_STACK_FRAME+                               , DELTA 0+                               ]++      let code =+            call_target_code -- compute the label (possibly into a register)+              `appOL` moveStackDown (stackSpaceWords)+              `appOL` passArgumentsCode -- put the arguments into x0, ...+              `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return)+              `appOL` readResultsCode -- parse the results into registers+              `appOL` moveStackUp (stackSpaceWords)+      return code++    PrimTarget MO_F32_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Fabs"+    PrimTarget MO_F64_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Fabs"++    PrimTarget MO_F32_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Sqrt"+    PrimTarget MO_F64_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Sqrt"++    PrimTarget (MO_Clz w)+      | w `elem` [W32, W64],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+      platform <- getPlatform+      (reg_x, _format_x, code_x) <- getSomeReg arg_reg+      let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+      return ( code_x `snocOL`+               CLZ (OpReg w dst_reg) (OpReg w reg_x)+             )+      | w `elem` [W8, W16],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+        platform <- getPlatform+        (reg_x, _format_x, code_x) <- getSomeReg arg_reg+        let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+        return ( code_x `appOL` toOL+                 [+                  MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),+                  SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))),+                  SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))),+                  OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),+                  CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg)+                 ]+               )+      | otherwise -> unsupported (MO_Clz w)+      where+        shift = widthToInt w++    PrimTarget (MO_Ctz w)+      | w `elem` [W32, W64],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+      platform <- getPlatform+      (reg_x, _format_x, code_x) <- getSomeReg arg_reg+      let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+      return ( code_x `snocOL`+               CTZ (OpReg w dst_reg) (OpReg w reg_x)+             )+      | w `elem` [W8, W16],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+      platform <- getPlatform+      (reg_x, _format_x, code_x) <- getSomeReg arg_reg+      let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+      return ( code_x `appOL` toOL+               [+                MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),+                SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)),+                BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)),+                OR  (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),+                CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg)+               ]+             )+      | otherwise -> unsupported (MO_Ctz w)+      where+        shift = (widthToInt w)++    -- mop :: CallishMachOp (see GHC.Cmm.MachOp)+    PrimTarget mop -> do+      -- We'll need config to construct forien targets+      case mop of+        -- 64 bit float ops+        MO_F64_Pwr   -> mkCCall "pow"++        MO_F64_Sin   -> mkCCall "sin"+        MO_F64_Cos   -> mkCCall "cos"+        MO_F64_Tan   -> mkCCall "tan"++        MO_F64_Sinh  -> mkCCall "sinh"+        MO_F64_Cosh  -> mkCCall "cosh"+        MO_F64_Tanh  -> mkCCall "tanh"++        MO_F64_Asin  -> mkCCall "asin"+        MO_F64_Acos  -> mkCCall "acos"+        MO_F64_Atan  -> mkCCall "atan"++        MO_F64_Asinh -> mkCCall "asinh"+        MO_F64_Acosh -> mkCCall "acosh"+        MO_F64_Atanh -> mkCCall "atanh"++        MO_F64_Log   -> mkCCall "log"+        MO_F64_Log1P -> mkCCall "log1p"+        MO_F64_Exp   -> mkCCall "exp"+        MO_F64_ExpM1 -> mkCCall "expm1"++        -- 32 bit float ops+        MO_F32_Pwr   -> mkCCall "powf"++        MO_F32_Sin   -> mkCCall "sinf"+        MO_F32_Cos   -> mkCCall "cosf"+        MO_F32_Tan   -> mkCCall "tanf"+        MO_F32_Sinh  -> mkCCall "sinhf"+        MO_F32_Cosh  -> mkCCall "coshf"+        MO_F32_Tanh  -> mkCCall "tanhf"+        MO_F32_Asin  -> mkCCall "asinf"+        MO_F32_Acos  -> mkCCall "acosf"+        MO_F32_Atan  -> mkCCall "atanf"+        MO_F32_Asinh -> mkCCall "asinhf"+        MO_F32_Acosh -> mkCCall "acoshf"+        MO_F32_Atanh -> mkCCall "atanhf"+        MO_F32_Log   -> mkCCall "logf"+        MO_F32_Log1P -> mkCCall "log1pf"+        MO_F32_Exp   -> mkCCall "expf"+        MO_F32_ExpM1 -> mkCCall "expm1f"++        -- 64-bit primops+        MO_I64_ToI   -> mkCCall "hs_int64ToInt"+        MO_I64_FromI -> mkCCall "hs_intToInt64"+        MO_W64_ToW   -> mkCCall "hs_word64ToWord"+        MO_W64_FromW -> mkCCall "hs_wordToWord64"+        MO_x64_Neg   -> mkCCall "hs_neg64"+        MO_x64_Add   -> mkCCall "hs_add64"+        MO_x64_Sub   -> mkCCall "hs_sub64"+        MO_x64_Mul   -> mkCCall "hs_mul64"+        MO_I64_Quot  -> mkCCall "hs_quotInt64"+        MO_I64_Rem   -> mkCCall "hs_remInt64"+        MO_W64_Quot  -> mkCCall "hs_quotWord64"+        MO_W64_Rem   -> mkCCall "hs_remWord64"+        MO_x64_And   -> mkCCall "hs_and64"+        MO_x64_Or    -> mkCCall "hs_or64"+        MO_x64_Xor   -> mkCCall "hs_xor64"+        MO_x64_Not   -> mkCCall "hs_not64"+        MO_x64_Shl   -> mkCCall "hs_uncheckedShiftL64"+        MO_I64_Shr   -> mkCCall "hs_uncheckedIShiftRA64"+        MO_W64_Shr   -> mkCCall "hs_uncheckedShiftRL64"+        MO_x64_Eq    -> mkCCall "hs_eq64"+        MO_x64_Ne    -> mkCCall "hs_ne64"+        MO_I64_Ge    -> mkCCall "hs_geInt64"+        MO_I64_Gt    -> mkCCall "hs_gtInt64"+        MO_I64_Le    -> mkCCall "hs_leInt64"+        MO_I64_Lt    -> mkCCall "hs_ltInt64"+        MO_W64_Ge    -> mkCCall "hs_geWord64"+        MO_W64_Gt    -> mkCCall "hs_gtWord64"+        MO_W64_Le    -> mkCCall "hs_leWord64"+        MO_W64_Lt    -> mkCCall "hs_ltWord64"++        -- Conversion+        MO_UF_Conv w        -> mkCCall (word2FloatLabel w)++        -- Optional MachOps+        -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config+        MO_S_Mul2     _w -> unsupported mop+        MO_S_QuotRem  _w -> unsupported mop+        MO_U_QuotRem  _w -> unsupported mop+        MO_U_QuotRem2 _w -> unsupported mop+        MO_Add2       _w -> unsupported mop+        MO_AddWordC   _w -> unsupported mop+        MO_SubWordC   _w -> unsupported mop+        MO_AddIntC    _w -> unsupported mop+        MO_SubIntC    _w -> unsupported mop+        MO_U_Mul2     _w -> unsupported mop++        MO_VS_Quot {} -> unsupported mop+        MO_VS_Rem {}  -> unsupported mop+        MO_VU_Quot {} -> unsupported mop+        MO_VU_Rem {}  -> unsupported mop+        MO_I64X2_Min -> unsupported mop+        MO_I64X2_Max -> unsupported mop+        MO_W64X2_Min -> unsupported mop+        MO_W64X2_Max -> unsupported mop++        -- Memory Ordering+        -- A hint value of 0 is mandatory by default, and it indicates a fully functional synchronization barrier.+        -- Only after all previous load/store access operations are completely executed, the DBAR 0 instruction can be executed;+        -- and only after the execution of DBAR 0 is completed, all subsequent load/store access operations can be executed.++        MO_AcquireFence -> pure (unitOL (DBAR Hint0))+        MO_ReleaseFence -> pure (unitOL (DBAR Hint0))+        MO_SeqCstFence  -> pure (unitOL (DBAR Hint0))++        MO_Touch        -> pure nilOL -- Keep variables live (when using interior pointers)+        -- Prefetch+        MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint.++        -- Memory copy/set/move/cmp, with alignment for optimization++        -- TODO Optimize and use e.g. quad registers to move memory around instead+        -- of offloading this to memcpy. For small memcpys we can utilize+        -- the 128bit quad registers in NEON to move block of bytes around.+        -- Might also make sense of small memsets? Use xzr? What's the function+        -- call overhead?+        MO_Memcpy  _align   -> mkCCall "memcpy"+        MO_Memset  _align   -> mkCCall "memset"+        MO_Memmove _align   -> mkCCall "memmove"+        MO_Memcmp  _align   -> mkCCall "memcmp"++        MO_SuspendThread    -> mkCCall "suspendThread"+        MO_ResumeThread     -> mkCCall "resumeThread"++        MO_PopCnt w         -> mkCCall (popCntLabel w)+        MO_Pdep w           -> mkCCall (pdepLabel w)+        MO_Pext w           -> mkCCall (pextLabel w)+        MO_BSwap w          -> mkCCall (bSwapLabel w)+        MO_BRev w           -> mkCCall (bRevLabel w)++    -- or a possibly side-effecting machine operation+        mo@(MO_AtomicRead w ord)+          | [p_reg] <- arg_regs+          , [dst_reg] <- dest_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              platform <- getPlatform+              let instrs = case ord of+                      MemOrderRelaxed -> unitOL $ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p))++                      MemOrderAcquire -> toOL [+                                                ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),+                                                DBAR Hint0+                                              ]+                      MemOrderSeqCst -> toOL [+                                                ann moDescr (DBAR Hint0),+                                                LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p),+                                                DBAR Hint0+                                              ]+                      _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo+                  dst = getRegisterReg platform (CmmLocal dst_reg)+                  moDescr = (text . show) mo+                  code = code_p `appOL` instrs+              pure code+          | otherwise -> panic "mal-formed AtomicRead"++        mo@(MO_AtomicWrite w ord)+          | [p_reg, val_reg] <- arg_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              (val, fmt_val, code_val) <- getSomeReg val_reg+              let instrs = case ord of+                      MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p))+                      MemOrderRelease -> toOL [+                                                ann moDescr (DBAR Hint0),+                                                ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)+                                              ]+                      MemOrderSeqCst  -> toOL [+                                                ann moDescr (DBAR Hint0),+                                                ST fmt_val (OpReg w val) (OpAddr $ AddrReg p),+                                                DBAR Hint0+                                              ]+                      _ ->  panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo+                  moDescr = (text . show) mo+                  code =+                    code_p `appOL`+                    code_val `appOL`+                    instrs+              pure code+          | otherwise -> panic "mal-formed AtomicWrite"++        MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)+        MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)+        MO_Xchg w           -> mkCCall (xchgLabel w)++  where+    unsupported :: Show a => a -> b+    unsupported mop = panic ("outOfLineCmmOp: " ++ show mop+                          ++ " not supported here")++    mkCCall :: FastString -> NatM InstrBlock+    mkCCall name = do+      config <- getConfig+      target <-+        cmmMakeDynamicReference config CallReference+          $ mkForeignLabel name ForeignLabelInThisPackage IsFunction+      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn+      genCCall (ForeignTarget target cconv) dest_regs arg_regs++    -- Implementiation of the LoongArch ABI calling convention.+    -- https://github.com/loongson/la-abi-specs/blob/release/lapcs.adoc#passing-arguments+    passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)++    -- 1. Base case: no more arguments to pass (left)+    passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode)++    -- 2. Still have GP regs, and we want to pass an GP argument.+    passArguments (gpReg : gpRegs) fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          ext+            -- Specifically, LoongArch64's ABI requires that the caller+            -- sign-extend arguments which are smaller than 64-bits.+            | w `elem` [W8, W16, W32]+            = case w of+              W8  -> EXT (OpReg W64 gpReg) (OpReg w r)+              W16 -> EXT (OpReg W64 gpReg) (OpReg w r)+              W32 -> SLL (OpReg W64 gpReg) (OpReg w r) (OpImm (ImmInt 0))+              _ -> panic "Unexpected width(Here w < W64)!"+            | otherwise+            = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                          code_r `snocOL`+                          ann (text "Pass gp argument: " <> ppr r) ext++      passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode'++    -- 3. Still have FP regs, and we want to pass an FP argument.+    passArguments gpRegs (fpReg : fpRegs) ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          mov = MOV (OpReg w fpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                       code_r `snocOL`+                       ann (text "Pass fp argument: " <> ppr r) mov++      passArguments gpRegs fpRegs args stackSpaceWords (fpReg : accumRegs) accumCode'++    -- 4. No mor regs left to pass. Must pass on stack.+    passArguments [] [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            code_r+              `snocOL` (MOV (OpReg w tmpReg) (OpReg w r))+              `appOL` truncateReg w W64 tmpReg+              `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str++      passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++    -- 5. Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.+    passArguments [] fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            code_r+              `snocOL` ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str++      passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++   -- 6. Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then.+    passArguments (gpReg : gpRegs) [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          mov = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                       code_r `snocOL`+                       ann (text "Pass fp argument in gpReg: " <> ppr r) mov++      passArguments gpRegs [] args stackSpaceWords (gpReg : accumRegs) accumCode'+++    passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")++    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock+    readResults _ _ [] _ accumCode = return accumCode+    readResults [] _ _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)+    readResults _ [] _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)+    readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do+      -- gp/fp reg -> dst+      platform <- getPlatform+      let rep = cmmRegType (CmmLocal dst)+          format = cmmTypeFormat rep+          w = cmmRegWidth (CmmLocal dst)+          r_dst = getRegisterReg platform (CmmLocal dst)+      if isFloatFormat format+        then readResults (gpReg : gpRegs) fpRegs dsts (fpReg : accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))+        else+          readResults gpRegs (fpReg : fpRegs) dsts (gpReg : accumRegs)+            $ accumCode+            `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)+            `appOL`+            -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations+            truncateReg W64 w r_dst++    unaryFloatOp w op arg_reg dest_reg = do+      platform <- getPlatform+      (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg+      let dst = getRegisterReg platform (CmmLocal dest_reg)+      let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)+      pure code++data BlockInRange = InRange | NotInRange BlockId++genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock+genCondFarJump cond op1 op2 far_target = do+  return $ toOL [ ann (text "Conditional far jump to: " <> ppr far_target)+                $ BCOND cond op1 op2 (TBlock far_target)+                ]++makeFarBranches ::+  Platform ->+  LabelMap RawCmmStatics ->+  [NatBasicBlock Instr] ->+  UniqDSM [NatBasicBlock Instr]++makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do+  -- All offsets/positions are counted in multiples of 4 bytes (the size of LoongArch64 instructions)+  -- That is an offset of 1 represents a 4-byte/one instruction offset.+  let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks+  if func_size < max_cond_jump_dist+    then pure basic_blocks+    else do+      (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks+      pure $ concat blocks+  where+    max_cond_jump_dist = 2 ^ (15 :: Int) - 8 :: Int+    -- Currently all inline info tables fit into 64 bytes.+    max_info_size = 16 :: Int+    long_bc_jump_dist = 2 :: Int++    -- Replace out of range conditional jumps with unconditional jumps.+    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])+    replace_blk !m !pos (BasicBlock lbl instrs) = do+      -- Account for a potential info table before the label.+      let !block_pos = pos + infoTblSize_maybe lbl+      (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs+      let instrs'' = concat instrs'+      -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.+      let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs''+      -- There should be no data in the instruction stream at this point+      massert (null no_data)++      let final_blocks = BasicBlock lbl top : split_blocks+      pure (pos', final_blocks)++    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])+    replace_jump !m !pos instr = do+      case instr of+        ANN ann instr -> do+          replace_jump m pos instr >>= \case+            (idx, instr' : instrs') -> pure (idx, ANN ann instr' : instrs')+            (idx, []) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx)++        BCOND1 cond op1 op2 t ->+          case target_in_range m t pos of+            InRange -> pure (pos + 1, [instr])+            NotInRange far_target -> do+              jmp_code <- genCondFarJump cond op1 op2 far_target+              pure (pos + long_bc_jump_dist, fromOL jmp_code)++        _ -> pure (pos + instr_size instr, [instr])++    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange+    target_in_range m target src =+      case target of+        (TReg{}) -> InRange+        (TBlock bid) -> block_in_range m src bid+        (TLabel clbl)+          | Just bid <- maybeLocalBlockLabel clbl+          -> block_in_range m src bid+          | otherwise+          -> InRange++    block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange+    block_in_range m src_pos dest_lbl =+      case mapLookup dest_lbl m of+        Nothing ->+          pprTrace "not in range" (ppr dest_lbl) $ NotInRange dest_lbl+        Just dest_pos ->+          if abs (dest_pos - src_pos) < max_cond_jump_dist+            then InRange+          else NotInRange dest_lbl++    calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)+    calc_lbl_positions (pos, m) (BasicBlock lbl instrs) =+      let !pos' = pos + infoTblSize_maybe lbl+       in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs++    instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)+    instr_pos (pos, m) instr = (pos + instr_size instr, m)++    infoTblSize_maybe bid =+      case mapLookup bid statics of+        Nothing -> 0 :: Int+        Just _info_static -> max_info_size++    instr_size :: Instr -> Int+    instr_size i = case i of+      COMMENT {} -> 0+      MULTILINE_COMMENT {} -> 0+      ANN _ instr -> instr_size instr+      LOCATION {} -> 0+      DELTA {} -> 0+      -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m)+      NEWBLOCK {} -> panic "mkFarBranched - Unexpected"+      LDATA {} -> panic "mkFarBranched - Unexpected"+      PUSH_STACK_FRAME -> 4+      POP_STACK_FRAME -> 4+      CSET {} -> 2+      LD _ _ (OpImm (ImmIndex _ _)) -> 3+      LD _ _ (OpImm (ImmCLbl _)) -> 2+      SCVTF {} -> 2+      FCVTZS {} -> 4+      BCOND {} -> long_bc_jump_dist+      CALL (TReg _) _ -> 1+      CALL {} -> 2+      CALL36 {} -> 2+      TAIL36 {} -> 2+      _ -> 1
+ compiler/GHC/CmmToAsm/LA64/Cond.hs view
@@ -0,0 +1,33 @@+module GHC.CmmToAsm.LA64.Cond where++import GHC.Prelude hiding (EQ)++-- | Condition codes.+-- Used in conditional branches and bit setters. According to the available+-- instruction set, some conditions are encoded as their negated opposites. I.e.+-- these are logical things that don't necessarily map 1:1 to hardware/ISA.+-- TODO: Maybe need to simplify or expand?+data Cond+-- ISA condition+  = EQ  -- beq+  | NE  -- bne+  | LT  -- blt+  | GE  -- bge+  | LTU  -- bltu+  | GEU  -- bgeu+  | EQZ  -- beqz+  | NEZ  -- bnez+-- Extra Logical condition+  | SLT -- LT+  | SLE+  | SGE -- GE+  | SGT+  | ULT -- LTU+  | ULE+  | UGE -- GEU+  | UGT+  | FLT+  | FLE+  | FGE+  | FGT+  deriving (Eq, Show)
+ compiler/GHC/CmmToAsm/LA64/Instr.hs view
@@ -0,0 +1,1012 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.CmmToAsm.LA64.Instr where++import GHC.Prelude++import GHC.CmmToAsm.LA64.Cond+import GHC.CmmToAsm.LA64.Regs++import GHC.CmmToAsm.Instr (RegUsage(..))+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.CmmToAsm.Config+import GHC.Platform.Reg++import GHC.Platform.Regs+import GHC.Platform.Reg.Class.Separate+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Utils.Outputable+import GHC.Platform+import GHC.Types.Unique.DSM++import GHC.Utils.Panic+import Data.Maybe+import GHC.Stack+import GHC.Data.FastString (LexicalFastString)++-- | Stack frame header size+-- Each stack frame contains ra and fp -- prologue.+stackFrameHeaderSize :: Int+stackFrameHeaderSize = 2 * spillSlotSize++-- | All registers are 8 byte wide.+spillSlotSize :: Int+spillSlotSize = 8++-- | The number of bytes that the stack pointer should be aligned to.+stackAlign :: Int+stackAlign = 16++-- | The number of spill slots available without allocating more.+maxSpillSlots :: NCGConfig -> Int+maxSpillSlots config+    = (+        (ncgSpillPreallocSize config - stackFrameHeaderSize)+         `div`+         spillSlotSize+      ) - 1++-- | Convert a spill slot number to a *byte* offset.+spillSlotToOffset :: Int -> Int+spillSlotToOffset slot+   = stackFrameHeaderSize + spillSlotSize * slot++instance Outputable RegUsage where+    ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')'++-- | Get the registers that are being used by this instruction.+-- regUsage doesn't need to do any trickery for jumps and such.+-- Just state precisely the regs read and written by that insn.+-- The consequences of control flow transfers, as far as register+-- allocation goes, are taken care of by the register allocator.+--+-- RegUsage = RU [<read regs>] [<write regs>]+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr = case instr of+  -- Pseudo Instructions+  ANN _ i                  -> regUsageOfInstr platform i+  COMMENT{}                -> usage ([], [])+  MULTILINE_COMMENT{}      -> usage ([], [])+  PUSH_STACK_FRAME         -> usage ([], [])+  POP_STACK_FRAME          -> usage ([], [])+  DELTA{}                  -> usage ([], [])+  LOCATION{}               -> usage ([], [])++  -- 1. Arithmetic Instructions ------------------------------------------------+  ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  SUB dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ALSL dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  ALSLU dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  LU12I dst src1           -> usage (regOp src1, regOp dst)+  LU32I dst src1           -> usage (regOp src1, regOp dst)+  LU52I dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  SSLT dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  SSLTU dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  PCADDI dst src1          -> usage (regOp src1, regOp dst)+  PCADDU12I dst src1       -> usage (regOp src1, regOp dst)+  PCADDU18I dst src1       -> usage (regOp src1, regOp dst)+  PCALAU12I dst src1       -> usage (regOp src1, regOp dst)+  AND dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  OR dst src1 src2         -> usage (regOp src1 ++ regOp src2, regOp dst)+  XOR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  NOR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ANDN dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  ORN dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MUL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULW dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULWU dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULH dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULHU dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIV dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIVU dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  MOD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MODU dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- 2. Bit-shift Instructions ------------------------------------------+  SLL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRA dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ROTR dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- 3. Bit Manipulation Instructions ------------------------------------------+  EXT dst src1             -> usage (regOp src1, regOp dst)+  CLO dst src1             -> usage (regOp src1, regOp dst)+  CLZ dst src1             -> usage (regOp src1, regOp dst)+  CTO dst src1             -> usage (regOp src1, regOp dst)+  CTZ dst src1             -> usage (regOp src1, regOp dst)+  BYTEPICK dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  REVB2H dst src1          -> usage (regOp src1, regOp dst)+  REVB4H dst src1          -> usage (regOp src1, regOp dst)+  REVB2W dst src1          -> usage (regOp src1, regOp dst)+  REVBD  dst src1          -> usage (regOp src1, regOp dst)+  REVH2W dst src1          -> usage (regOp src1, regOp dst)+  REVHD  dst src1          -> usage (regOp src1, regOp dst)+  BITREV4B dst src1        -> usage (regOp src1, regOp dst)+  BITREV8B dst src1        -> usage (regOp src1, regOp dst)+  BITREVW dst src1         -> usage (regOp src1, regOp dst)+  BITREVD dst src1         -> usage (regOp src1, regOp dst)+  BSTRINS _ dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  BSTRPICK _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  MASKEQZ dst src1 src2         -> usage (regOp src1 ++ regOp src2, regOp dst)+  MASKNEZ dst src1 src2         -> usage (regOp src1 ++ regOp src2, regOp dst)+  --+  -- Pseudo instructions+  NOP                      -> usage ([], [])+  MOV dst src              -> usage (regOp src, regOp dst)+  NEG dst src              -> usage (regOp src, regOp dst)+  CSET _cond dst src1 src2  -> usage (regOp src1 ++ regOp src2 , regOp dst)+  -- 4. Branch Instructions ----------------------------------------------------+  J t                      -> usage (regTarget t, [])+  J_TBL _ _ t              -> usage ([t], [])+  B t                      -> usage (regTarget t, [])+  BL t ps                  -> usage (regTarget t ++ ps, callerSavedRegisters)+  CALL t ps                -> usage (regTarget t ++ ps, callerSavedRegisters)+  CALL36 t                 -> usage (regTarget t, [])+  TAIL36 r t               -> usage (regTarget t, regOp r)+  -- Here two kinds of BCOND and BCOND1 are implemented, mainly because we want+  -- to distinguish between two kinds of conditional jumps with different jump+  -- ranges, corresponding to 2 and 1 instruction implementations respectively.+  --+  -- BCOND1 is selected by default.+  BCOND1 _ j d t           -> usage (regTarget t ++ regOp j ++ regOp d, [])+  BCOND _ j d t            -> usage (regTarget t ++ regOp j ++ regOp d, [])+  BEQZ j t                 -> usage (regTarget t ++ regOp j, [])+  BNEZ j t                 -> usage (regTarget t ++ regOp j, [])+  -- 5. Common Memory Access Instructions --------------------------------------+  LD _ dst src             -> usage (regOp src, regOp dst)+  LDU _ dst src            -> usage (regOp src, regOp dst)+  ST _ dst src             -> usage (regOp src ++ regOp dst, [])+  LDX _ dst src            -> usage (regOp src, regOp dst)+  LDXU _ dst src           -> usage (regOp src, regOp dst)+  STX _ dst src            -> usage (regOp src ++ regOp dst, [])+  LDPTR _ dst src          -> usage (regOp src, regOp dst)+  STPTR _ dst src          -> usage (regOp src ++ regOp dst, [])+  PRELD _hint src          -> usage (regOp src, [])+  -- 6. Bound Check Memory Access Instructions ---------------------------------+  -- LDCOND dst src1 src2     -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- STCOND dst src1 src2     -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- 7. Atomic Memory Access Instructions --------------------------------------+  -- 8. Barrier Instructions ---------------------------------------------------+  DBAR _hint               -> usage ([], [])+  IBAR _hint               -> usage ([], [])+  -- 11. Floating Point Instructions -------------------------------------------+  FMAX dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMIN dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMAXA dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMINA dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  FNEG dst src1            -> usage (regOp src1, regOp dst)++  FCVT dst src             -> usage (regOp src, regOp dst)+  -- SCVTF dst src            -> usage (regOp src, regOp src ++ regOp dst)+  SCVTF dst src            -> usage (regOp src, regOp dst)+  FCVTZS dst src1 src2     -> usage (regOp src2, regOp src1 ++ regOp dst)+  FABS dst src             -> usage (regOp src, regOp dst)+  FSQRT dst src            -> usage (regOp src, regOp dst)+  FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)++  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr++  where+        -- filtering the usage is necessary, otherwise the register+        -- allocator will try to allocate pre-defined fixed stg+        -- registers as well, as they show up.+        usage :: ([Reg], [Reg]) -> RegUsage+        usage (srcRegs, dstRegs) =+          RU+            (map mkFmt $ filter (interesting platform) srcRegs)+            (map mkFmt $ filter (interesting platform) dstRegs)++        mkFmt r = RegWithFormat r fmt+          where+            fmt = case cls of+              RcInteger -> II64+              RcFloat   -> FF64+              RcVector  -> sorry "The LoongArch64 NCG does not (yet) support vectors; please use -fllvm."+            cls = case r of+              RegVirtual vr -> classOfVirtualReg (platformArch platform) vr+              RegReal rr -> classOfRealReg rr++        regAddr :: AddrMode -> [Reg]+        regAddr (AddrRegReg r1 r2) = [r1, r2]+        regAddr (AddrRegImm r1 _)  = [r1]+        regAddr (AddrReg r1)       = [r1]++        regOp :: Operand -> [Reg]+        regOp (OpReg _ r1) = [r1]+        regOp (OpAddr a)    = regAddr a+        regOp (OpImm _)     = []++        regTarget :: Target -> [Reg]+        regTarget (TBlock _) = []+        regTarget (TLabel _) = []+        regTarget (TReg r1)  = [r1]++        -- Is this register interesting for the register allocator?+        interesting :: Platform -> Reg -> Bool+        interesting _        (RegVirtual _)                 = True+        interesting platform (RegReal (RealRegSingle i))    = freeReg platform i++-- | Caller-saved registers (according to calling convention)+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- |  0 |  1 |  2 |  3 |  4 |  5 |  6 |  7 |  8 |  9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- |zero| ra | tp | sp | a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | Rv | fp | s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 | s8 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 42 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+--f| a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | t9 | t10| t11| t12| t13| t14| t15| s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+callerSavedRegisters :: [Reg]+callerSavedRegisters =+    -- TODO: Not sure.+    [regSingle 1]                 -- ra+    ++ map regSingle [4 .. 11]    -- a0 - a7+    ++ map regSingle [12 .. 20]   -- t0 - t8+    ++ map regSingle [32 .. 39]   -- fa0 - fa7+    ++ map regSingle [40 .. 55]   -- ft0 - ft15++-- | Apply a given mapping to all the register references in this instruction.+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of+    -- 0. Meta Instructions+    ANN d i             -> ANN d (patchRegsOfInstr i env)+    COMMENT{}           -> instr+    MULTILINE_COMMENT{} -> instr+    PUSH_STACK_FRAME    -> instr+    POP_STACK_FRAME     -> instr+    DELTA{}             -> instr+    LOCATION{}          -> instr+    -- 1. Arithmetic Instructions ------------------------------------------------+    ADD o1 o2 o3        -> ADD  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SUB o1 o2 o3        -> SUB  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ALSL o1 o2 o3 o4    -> ALSL  (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    ALSLU o1 o2 o3 o4   -> ALSLU (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    LU12I o1 o2         -> LU12I  (patchOp o1)  (patchOp o2)+    LU32I o1 o2         -> LU32I  (patchOp o1)  (patchOp o2)+    LU52I o1 o2 o3      -> LU52I  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SSLT o1 o2 o3       -> SSLT  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SSLTU o1 o2 o3      -> SSLTU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    PCADDI o1 o2        -> PCADDI  (patchOp o1)  (patchOp o2)+    PCADDU12I o1 o2     -> PCADDU12I  (patchOp o1)  (patchOp o2)+    PCADDU18I o1 o2     -> PCADDU18I  (patchOp o1)  (patchOp o2)+    PCALAU12I o1 o2     -> PCALAU12I  (patchOp o1)  (patchOp o2)+    AND o1 o2 o3        -> AND  (patchOp o1)  (patchOp o2)  (patchOp o3)+    OR o1 o2 o3         -> OR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    XOR o1 o2 o3        -> XOR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    NOR o1 o2 o3        -> NOR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ANDN o1 o2 o3       -> ANDN  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ORN o1 o2 o3        -> ORN  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MUL o1 o2 o3        -> MUL  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULW o1 o2 o3       -> MULW  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULWU o1 o2 o3      -> MULWU (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULH o1 o2 o3       -> MULH  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULHU o1 o2 o3      -> MULHU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    DIV o1 o2 o3        -> DIV  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MOD o1 o2 o3        -> MOD  (patchOp o1)  (patchOp o2)  (patchOp o3)+    DIVU o1 o2 o3       -> DIVU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MODU o1 o2 o3       -> MODU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- 2. Bit-shift Instructions ------------------------------------------+    SLL o1 o2 o3        -> SLL  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SRL o1 o2 o3        -> SRL  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SRA o1 o2 o3        -> SRA  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ROTR o1 o2 o3       -> ROTR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- 3. Bit Manipulation Instructions ------------------------------------------+    EXT o1 o2             -> EXT  (patchOp o1)  (patchOp o2)+    CLO o1 o2             -> CLO  (patchOp o1)  (patchOp o2)+    CLZ o1 o2             -> CLZ  (patchOp o1)  (patchOp o2)+    CTO o1 o2             -> CTO  (patchOp o1)  (patchOp o2)+    CTZ o1 o2             -> CTZ  (patchOp o1)  (patchOp o2)+    BYTEPICK o1 o2 o3 o4  -> BYTEPICK  (patchOp o1)  (patchOp o2) (patchOp o3) (patchOp o4)+    REVB2H o1 o2          -> REVB2H  (patchOp o1)  (patchOp o2)+    REVB4H o1 o2          -> REVB4H  (patchOp o1)  (patchOp o2)+    REVB2W o1 o2          -> REVB2W  (patchOp o1)  (patchOp o2)+    REVBD  o1 o2          -> REVBD  (patchOp o1)  (patchOp o2)+    REVH2W o1 o2          -> REVH2W  (patchOp o1)  (patchOp o2)+    REVHD  o1 o2          -> REVHD  (patchOp o1)  (patchOp o2)+    BITREV4B o1 o2         -> BITREV4B  (patchOp o1)  (patchOp o2)+    BITREV8B o1 o2         -> BITREV8B  (patchOp o1)  (patchOp o2)+    BITREVW o1 o2          -> BITREVW  (patchOp o1)  (patchOp o2)+    BITREVD o1 o2          -> BITREVD  (patchOp o1)  (patchOp o2)+    BSTRINS f o1 o2 o3 o4  -> BSTRINS f (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    BSTRPICK f o1 o2 o3 o4 -> BSTRPICK f (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    MASKEQZ o1 o2 o3       -> MASKEQZ  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MASKNEZ o1 o2 o3       -> MASKNEZ  (patchOp o1)  (patchOp o2)  (patchOp o3)+    --+    -- Pseudo instrcutions+    NOP                 -> NOP+    MOV o1 o2           -> MOV  (patchOp o1)  (patchOp o2)+    NEG o1 o2           -> NEG  (patchOp o1)  (patchOp o2)+    CSET cond o1 o2 o3  -> CSET cond (patchOp o1) (patchOp o2) (patchOp o3)+    -- 4. Branch Instructions ----------------------------------------------------+    -- TODO:+    J t            -> J (patchTarget t)+    J_TBL ids mbLbl t  -> J_TBL ids mbLbl (env t)+    B t            -> B (patchTarget t)+    BL t ps        -> BL (patchTarget t) ps+    CALL t ps      -> CALL (patchTarget t) ps+    CALL36 t       -> CALL36 (patchTarget t)+    TAIL36 r t     -> TAIL36 (patchOp r) (patchTarget t)+    BCOND1 c j d t -> BCOND1 c (patchOp j) (patchOp d) (patchTarget t)+    BCOND c j d t  -> BCOND c (patchOp j) (patchOp d) (patchTarget t)+    BEQZ j t       -> BEQZ (patchOp j) (patchTarget t)+    BNEZ j t       -> BNEZ (patchOp j) (patchTarget t)+    -- 5. Common Memory Access Instructions --------------------------------------+    -- TODO:+    LD f o1 o2         -> LD f (patchOp o1)  (patchOp o2)+    LDU f o1 o2        -> LDU f (patchOp o1)  (patchOp o2)+    ST f o1 o2         -> ST f (patchOp o1)  (patchOp o2)+    LDX f o1 o2        -> LDX f (patchOp o1)  (patchOp o2)+    LDXU f o1 o2       -> LDXU f (patchOp o1)  (patchOp o2)+    STX f o1 o2        -> STX f (patchOp o1)  (patchOp o2)+    LDPTR f o1 o2      -> LDPTR f (patchOp o1)  (patchOp o2)+    STPTR f o1 o2      -> STPTR f (patchOp o1)  (patchOp o2)+    PRELD o1 o2         -> PRELD (patchOp o1) (patchOp o2)+    -- 6. Bound Check Memory Access Instructions ---------------------------------+    -- LDCOND o1 o2 o3       -> LDCOND  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- STCOND o1 o2 o3       -> STCOND  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- 7. Atomic Memory Access Instructions --------------------------------------+    -- 8. Barrier Instructions ---------------------------------------------------+    -- TODO: need fix+    DBAR o1             -> DBAR o1+    IBAR o1             -> IBAR o1+    -- 11. Floating Point Instructions -------------------------------------------+    FCVT o1 o2          -> FCVT  (patchOp o1)  (patchOp o2)+    SCVTF o1 o2         -> SCVTF  (patchOp o1)  (patchOp o2)+    FCVTZS o1 o2 o3     -> FCVTZS  (patchOp o1)  (patchOp o2) (patchOp o3)+    FMIN o1 o2 o3       -> FMIN  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FMAX o1 o2 o3       -> FMAX  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FMINA o1 o2 o3      -> FMINA  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FMAXA o1 o2 o3      -> FMAXA  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FNEG o1 o2          -> FNEG  (patchOp o1)  (patchOp o2)+    FABS o1 o2          -> FABS  (patchOp o1)  (patchOp o2)+    FSQRT o1 o2         -> FSQRT  (patchOp o1)  (patchOp o2)+    FMA s o1 o2 o3 o4   -> FMA s (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)++    _                   -> panic $ "patchRegsOfInstr: " ++ instrCon instr+    where+        -- TODO:+        patchOp :: Operand -> Operand+        patchOp (OpReg w r) = OpReg w (env r)+        patchOp (OpAddr a) = OpAddr (patchAddr a)+        patchOp opImm = opImm++        patchTarget :: Target -> Target+        patchTarget (TReg r) = TReg (env r)+        patchTarget t = t++        patchAddr :: AddrMode -> AddrMode+        patchAddr (AddrRegReg r1 r2)  = AddrRegReg (env r1) (env r2)+        patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm+        patchAddr (AddrReg r) = AddrReg (env r)++--------------------------------------------------------------------------------++-- | Checks whether this instruction is a jump/branch instruction.+-- One that can change the flow of control in a way that the+-- register allocator needs to worry about.+isJumpishInstr :: Instr -> Bool+isJumpishInstr instr = case instr of+  ANN _ i -> isJumpishInstr i+  J {} -> True+  J_TBL {} -> True+  B {} -> True+  BL {} -> True+  CALL {} -> True+  CALL36 {} -> True+  TAIL36 {} -> True+  BCOND1 {} -> True+  BCOND {} -> True+  BEQZ {} -> True+  BNEZ {} -> True+  _ -> False++-- | Get the `BlockId`s of the jump destinations (if any)+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i+jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BL t _) = [id | TBlock id <- [t]]+jumpDestsOfInstr (CALL t _) = [id | TBlock id <- [t]]+jumpDestsOfInstr (CALL36 t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (TAIL36 _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND1 _ _ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BEQZ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BNEZ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr _ = []++-- | Change the destination of this (potential) jump instruction.+-- Used in the linear allocator when adding fixup blocks for join+-- points.+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+patchJumpInstr instr patchF =+  case instr of+    ANN d i -> ANN d (patchJumpInstr i patchF)+    J (TBlock bid) -> J (TBlock (patchF bid))+    J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r+    B (TBlock bid) -> B (TBlock (patchF bid))+    BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps+    CALL (TBlock bid) ps -> CALL (TBlock (patchF bid)) ps+    CALL36 (TBlock bid) -> CALL36 (TBlock (patchF bid))+    TAIL36 r (TBlock bid) -> TAIL36 r (TBlock (patchF bid))+    BCOND1 c o1 o2 (TBlock bid) -> BCOND1 c o1 o2 (TBlock (patchF bid))+    BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))+    BEQZ j (TBlock bid) -> BEQZ j (TBlock (patchF bid))+    BNEZ j (TBlock bid) -> BNEZ j (TBlock (patchF bid))+    _ -> panic $ "patchJumpInstr: " ++ instrCon instr++-- -----------------------------------------------------------------------------+-- | Make a spill instruction, spill a register into spill slot.+mkSpillInstr+   :: HasCallStack+   => NCGConfig+   -> RegWithFormat -- register to spill+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkSpillInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsInNbits 12 imm -> [mkStrSpImm imm]+    imm ->+      [ movImmToIp imm,+        addSpToIp,+        mkStrIp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < 32 -> II64+      _ -> FF64+    mkStrSpImm imm = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToIp imm = ANN (text "Spill: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm))+    addSpToIp = ANN (text "Spill: TMP <- SP + TMP ") $ ADD tmp tmp sp+    mkStrIp = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))+    off = spillSlotToOffset slot++-- | Make a reload instruction, reload from spill slot to a register.+mkLoadInstr+   :: NCGConfig+   -> RegWithFormat+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkLoadInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsInNbits 12 imm -> [mkLdrSpImm imm]+    imm ->+      [ movImmToIp imm,+        addSpToIp,+        mkLdrIp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < 32 -> II64+      _ -> FF64+    mkLdrSpImm imm = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToIp imm = ANN (text "Reload: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm))+    addSpToIp = ANN (text "Reload: TMP <- SP + TMP ") $ ADD tmp tmp sp+    mkLdrIp = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))+    off = spillSlotToOffset slot++-- | See if this instruction is telling us the current C stack delta+takeDeltaInstr :: Instr -> Maybe Int+takeDeltaInstr (ANN _ i) = takeDeltaInstr i+takeDeltaInstr (DELTA i) = Just i+takeDeltaInstr _         = Nothing++-- | Not real instructions.  Just meta data+isMetaInstr :: Instr -> Bool+isMetaInstr instr =+  case instr of+    ANN _ i -> isMetaInstr i+    COMMENT {} -> True+    MULTILINE_COMMENT {} -> True+    LOCATION {} -> True+    NEWBLOCK {} -> True+    DELTA {} -> True+    LDATA {} -> True+    PUSH_STACK_FRAME -> True+    POP_STACK_FRAME -> True+    _ -> False++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid =+  case insn of+    J (TBlock target) -> bid == target+    J_TBL targets _ _ -> all isTargetBid targets+    B (TBlock target) -> bid == target+    TAIL36 _ (TBlock target) -> bid == target+    BCOND1 _ _ _ (TBlock target) -> bid == target+    BCOND _ _ _ (TBlock target) -> bid == target+    _ -> False+  where+    isTargetBid target = case target of+      Nothing -> True+      Just target -> target == bid++-- | Copy the value in a register to another one.+-- Must work for all register classes.+mkRegRegMoveInstr :: Reg -> Reg -> Instr+mkRegRegMoveInstr src dst = ANN desc instr+  where+    desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst+    instr = MOV (OpReg W64 dst) (OpReg W64 src)++-- | Take the source and destination from this (potential) reg -> reg move instruction+-- We have to be a bit careful here: A `MOV` can also mean an implicit+-- conversion. This case is filtered out.+takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)+takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src))+  | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst)+takeRegRegMoveInstr _ = Nothing++-- | Make an unconditional jump instruction.+mkJumpInstr :: BlockId -> [Instr]+mkJumpInstr id = [TAIL36 (OpReg W64 tmpReg) (TBlock (id))]++-- | Decrement @sp@ to allocate stack space.+mkStackAllocInstr :: Platform -> Int -> [Instr]+mkStackAllocInstr _platform n+  | n == 0 = []+  | n > 0 && fitsInNbits 12 (fromIntegral n) =+      [ ANN (text "Alloc stack") $ SUB sp sp (OpImm (ImmInt n)) ]+  | n > 0 =+     [+         ANN (text "Alloc more stack") (MOV tmp (OpImm (ImmInt n))),+         SUB sp sp tmp+     ]+mkStackAllocInstr _platform n = pprPanic "mkStackAllocInstr" (int n)++-- | Increment SP to deallocate stack space.+mkStackDeallocInstr :: Platform -> Int -> [Instr]+mkStackDeallocInstr _platform  n+  | n == 0 = []+  | n > 0 && fitsInNbits 12 (fromIntegral n) =+      [ ANN (text "Dealloc stack") $ ADD sp sp (OpImm (ImmInt n)) ]+  | n > 0 =+     [+         ANN (text "Dealloc more stack") (MOV tmp (OpImm (ImmInt n))),+         ADD sp sp tmp+     ]+mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n)++allocMoreStack+  :: Platform+  -> Int+  -> NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr+  -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr, [(BlockId,BlockId)])++allocMoreStack _ _ top@(CmmData _ _) = return (top, [])+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do+  let entries = entryBlocks proc++  retargetList <- mapM (\e -> (e,) <$> newBlockId) entries++  let+    delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+      where x = slots * spillSlotSize -- sp delta++    alloc   = mkStackAllocInstr   platform delta+    dealloc = mkStackDeallocInstr platform delta++    new_blockmap :: LabelMap BlockId+    new_blockmap = mapFromList retargetList++    insert_stack_insn (BasicBlock id insns)+      | Just new_blockid <- mapLookup id new_blockmap =+        [ BasicBlock id $ alloc ++ [ B (TBlock new_blockid) ],+          BasicBlock new_blockid block' ]+      | otherwise =+        [ BasicBlock id block' ]+      where+        block' = foldr insert_dealloc [] insns++    insert_dealloc insn r = case insn of+      J {} -> dealloc ++ (insn : r)+      ANN _ e -> insert_dealloc e r+      _other | jumpDestsOfInstr insn /= [] ->+        patchJumpInstr insn retarget : r+      _other -> insn : r++      where retarget b = fromMaybe b (mapLookup b new_blockmap)++    new_code = concatMap insert_stack_insn code+  return (CmmProc info lbl live (ListGraph new_code), retargetList)++-- -----------------------------------------------------------------------------+-- Machine's assembly language++-- We have a few common "instructions" (nearly all the pseudo-ops) but+-- mostly all of 'Instr' is machine-specific.++data Instr+    -- comment pseudo-op+    = COMMENT SDoc+    | MULTILINE_COMMENT SDoc++    -- Annotated instruction. Should print <instr> # <doc>+    | ANN SDoc Instr++    -- location pseudo-op (file, line, col, name)+    | LOCATION Int Int Int LexicalFastString++    -- start a new basic block.  Useful during codegen, removed later.+    -- Preceding instruction should be a jump, as per the invariants+    -- for a BasicBlock (see Cmm).+    | NEWBLOCK BlockId++    -- specify current stack offset for benefit of subsequent passes.+    -- This carries a BlockId so it can be used in unwinding information.+    | DELTA   Int++    -- | Static data spat out during code generation.+    | LDATA Section RawCmmStatics++    | PUSH_STACK_FRAME+    | POP_STACK_FRAME+    -- Basic Integer Instructions ------------------------------------------------+    -- 1. Arithmetic Instructions ------------------------------------------------+    | ADD Operand Operand Operand+    | SUB Operand Operand Operand+    | ALSL Operand Operand Operand Operand+    | ALSLU Operand Operand Operand Operand+    | LU12I Operand Operand+    | LU32I Operand Operand+    | LU52I Operand Operand Operand+    | SSLT Operand Operand Operand+    | SSLTU Operand Operand Operand+    | PCADDI Operand Operand+    | PCADDU12I Operand Operand+    | PCADDU18I Operand Operand+    | PCALAU12I Operand Operand+    | AND Operand Operand Operand+    | OR Operand Operand Operand+    | XOR Operand Operand Operand+    | NOR Operand Operand Operand+    | ANDN Operand Operand Operand+    | ORN Operand Operand Operand+    | MUL Operand Operand Operand+    | MULW Operand Operand Operand+    | MULWU Operand Operand Operand+    | MULH Operand Operand Operand+    | MULHU Operand Operand Operand+    | DIV Operand Operand Operand+    | DIVU Operand Operand Operand+    | MOD Operand Operand Operand+    | MODU Operand Operand Operand+    -- 2. Bit-shift Instuctions --------------------------------------------------+    | SLL Operand Operand Operand+    | SRL Operand Operand Operand+    | SRA Operand Operand Operand+    | ROTR Operand Operand Operand+    -- 3. Bit-manupulation Instructions ------------------------------------------+    | EXT Operand Operand+    | CLO Operand Operand+    | CTO Operand Operand+    | CLZ Operand Operand+    | CTZ Operand Operand+    | BYTEPICK Operand Operand Operand Operand+    | REVB2H Operand Operand+    | REVB4H Operand Operand+    | REVB2W Operand Operand+    | REVBD Operand Operand+    | REVH2W Operand Operand+    | REVHD Operand Operand+    | BITREV4B Operand Operand+    | BITREV8B Operand Operand+    | BITREVW Operand Operand+    | BITREVD Operand Operand+    | BSTRINS Format Operand Operand Operand Operand+    | BSTRPICK Format Operand Operand Operand Operand+    | MASKEQZ Operand Operand Operand+    | MASKNEZ Operand Operand Operand+    -- Pseudo instructions+    | NOP+    | MOV Operand Operand+    | NEG Operand Operand+    | CSET Cond Operand Operand Operand+    -- 4. Branch Instructions ----------------------------------------------------+    | J Target+    | J_TBL [Maybe BlockId] (Maybe CLabel) Reg+    | B Target+    | BL Target [Reg]+    | CALL Target [Reg]+    | CALL36 Target+    | TAIL36 Operand Target+    | BCOND1 Cond Operand Operand Target+    | BCOND Cond Operand Operand Target+    | BEQZ Operand Target+    | BNEZ Operand Target+    -- 5. Common Memory Access Instructions --------------------------------------+    | LD Format Operand Operand+    | LDU Format Operand Operand+    | ST Format Operand Operand+    | LDX Format Operand Operand+    | LDXU Format Operand Operand+    | STX Format Operand Operand+    | LDPTR Format Operand Operand+    | STPTR Format Operand Operand+    | PRELD Operand Operand+    -- 6. Bound Check Memory Access Instructions ---------------------------------+    -- 7. Atomic Memory Access Instructions --------------------------------------+    -- 8. Barrier Instructions ---------------------------------------------------+    | DBAR BarrierType+    | IBAR BarrierType+    -- Basic Floating Point Instructions -----------------------------------------+    | FCVT    Operand Operand+    | SCVTF   Operand Operand+    | FCVTZS  Operand Operand Operand+    | FMAX Operand Operand Operand+    | FMIN Operand Operand Operand+    | FMAXA Operand Operand Operand+    | FMINA Operand Operand Operand+    | FNEG Operand Operand+    | FABS Operand Operand+    | FSQRT Operand Operand+    -- Floating-point fused multiply-add instructions+    --  fmadd : d =   r1 * r2 + r3+    --  fnmsub: d =   r1 * r2 - r3+    --  fmsub : d = - r1 * r2 + r3+    --  fnmadd: d = - r1 * r2 - r3+    | FMA FMASign Operand Operand Operand Operand++-- TODO: Not complete.+data BarrierType = Hint0++instrCon :: Instr -> String+instrCon i =+    case i of+      COMMENT{} -> "COMMENT"+      MULTILINE_COMMENT{} -> "COMMENT"+      ANN{} -> "ANN"+      LOCATION{} -> "LOCATION"+      NEWBLOCK{} -> "NEWBLOCK"+      DELTA{} -> "DELTA"+      LDATA {} -> "LDATA"+      PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"+      POP_STACK_FRAME{} -> "POP_STACK_FRAME"++      ADD{} -> "ADD"+      SUB{} -> "SUB"+      ALSL{} -> "ALSL"+      ALSLU{} -> "ALSLU"+      LU12I{} -> "LU12I"+      LU32I{} -> "LU32I"+      LU52I{} -> "LU52I"+      SSLT{} -> "SSLT"+      SSLTU{} -> "SSLTU"+      PCADDI{} -> "PCADDI"+      PCADDU12I{} -> "PCADDU12I"+      PCADDU18I{} -> "PCADDU18I"+      PCALAU12I{} -> "PCALAU12I"+      AND{} -> "AND"+      OR{} -> "OR"+      XOR{} -> "XOR"+      NOR{} -> "NOR"+      ANDN{} -> "ANDN"+      ORN{} -> "ORN"+      MUL{} -> "MUL"+      MULW{} -> "MULW"+      MULWU{} -> "MULWU"+      MULH{} -> "MULH"+      MULHU{} -> "MULHU"+      DIV{} -> "DIV"+      MOD{} -> "MOD"+      DIVU{} -> "DIVU"+      MODU{} -> "MODU"+      SLL{} -> "SLL"+      SRL{} -> "SRL"+      SRA{} -> "SRA"+      ROTR{} -> "ROTR"+      EXT{} -> "EXT"+      CLO{} -> "CLO"+      CLZ{} -> "CLZ"+      CTO{} -> "CTO"+      CTZ{} -> "CTZ"+      BYTEPICK{} -> "BYTEPICK"+      REVB2H{} -> "REVB2H"+      REVB4H{} -> "REVB4H"+      REVB2W{} -> "REVB2W"+      REVBD{} -> "REVBD"+      REVH2W{} -> "REVH2W"+      REVHD{} -> "REVHD"+      BITREV4B{} -> "BITREV4B"+      BITREV8B{} -> "BITREV8B"+      BITREVW{} -> "BITREVW"+      BITREVD{} -> "BITREVD"+      BSTRINS{} -> "BSTRINS"+      BSTRPICK{} -> "BSTRPICK"+      MASKEQZ{} -> "MASKEQZ"+      MASKNEZ{} -> "MASKNEZ"+      NOP{} -> "NOP"+      MOV{} -> "MOV"+      NEG{} -> "NEG"+      CSET{} -> "CSET"+      J{} -> "J"+      J_TBL{} -> "J_TBL"+      B{} -> "B"+      BL{} -> "BL"+      CALL{} -> "CALL"+      CALL36{} -> "CALL36"+      TAIL36{} -> "TAIL36"+      BCOND1{} -> "BCOND1"+      BCOND{} -> "BCOND"+      BEQZ{} -> "BEQZ"+      BNEZ{} -> "BNEZ"+      LD{} -> "LD"+      LDU{} -> "LDU"+      ST{} -> "ST"+      LDX{} -> "LDX"+      LDXU{} -> "LDXU"+      STX{} -> "STX"+      LDPTR{} -> "LDPTR"+      STPTR{} -> "STPTR"+      PRELD{} -> "PRELD"+      DBAR{} -> "DBAR"+      IBAR{} -> "IBAR"+      FCVT{} -> "FCVT"+      SCVTF{} -> "SCVTF"+      FCVTZS{} -> "FCVTZS"+      FMAX{} -> "FMAX"+      FMIN{} -> "FMIN"+      FMAXA{} -> "FMAXA"+      FMINA{} -> "FMINA"+      FNEG{} -> "FNEG"+      FABS{} -> "FABS"+      FSQRT{} -> "FSQRT"+      FMA variant _ _ _ _ ->+        case variant of+          FMAdd  -> "FMADD"+          FMSub  -> "FMSUB"+          FNMAdd -> "FNMADD"+          FNMSub -> "FNMSUB"++data Target+    = TBlock BlockId+    | TLabel CLabel+    | TReg   Reg++data Operand+  = OpReg Width Reg -- register+  | OpImm Imm       -- immediate+  | OpAddr AddrMode -- address+  deriving (Eq, Show)++opReg :: Reg -> Operand+opReg = OpReg W64++opRegNo :: RegNo -> Operand+opRegNo = opReg . regSingle++-- LoongArch64 has no ip register in ABI. Here ip register is for spilling/+-- reloading register to/from slots. So make t8(r20) non-free for ip.+zero, ra, tp, sp, fp, tmp :: Operand+zero = opReg zeroReg+ra   = opReg raReg+sp   = opReg spMachReg+tp   = opReg tpMachReg+fp   = opReg fpMachReg+tmp  = opReg tmpReg++x0,  x1,  x2,  x3,  x4,  x5,  x6,  x7  :: Operand+x8,  x9,  x10, x11, x12, x13, x14, x15 :: Operand+x16, x17, x18, x19, x20, x21, x22, x23 :: Operand+x24, x25, x26, x27, x28, x29, x30, x31 :: Operand+x0  = opRegNo  0+x1  = opRegNo  1+x2  = opRegNo  2+x3  = opRegNo  3+x4  = opRegNo  4+x5  = opRegNo  5+x6  = opRegNo  6+x7  = opRegNo  7+x8  = opRegNo  8+x9  = opRegNo  9+x10 = opRegNo 10+x11 = opRegNo 11+x12 = opRegNo 12+x13 = opRegNo 13+x14 = opRegNo 14+x15 = opRegNo 15+x16 = opRegNo 16+x17 = opRegNo 17+x18 = opRegNo 18+x19 = opRegNo 19+x20 = opRegNo 20+x21 = opRegNo 21+x22 = opRegNo 22+x23 = opRegNo 23+x24 = opRegNo 24+x25 = opRegNo 25+x26 = opRegNo 26+x27 = opRegNo 27+x28 = opRegNo 18+x29 = opRegNo 29+x30 = opRegNo 30+x31 = opRegNo 31++d0,  d1,  d2,  d3,  d4,  d5,  d6,  d7  :: Operand+d8,  d9,  d10, d11, d12, d13, d14, d15 :: Operand+d16, d17, d18, d19, d20, d21, d22, d23 :: Operand+d24, d25, d26, d27, d28, d29, d30, d31 :: Operand+d0  = opRegNo 32+d1  = opRegNo 33+d2  = opRegNo 34+d3  = opRegNo 35+d4  = opRegNo 36+d5  = opRegNo 37+d6  = opRegNo 38+d7  = opRegNo 39+d8  = opRegNo 40+d9  = opRegNo 41+d10 = opRegNo 42+d11 = opRegNo 43+d12 = opRegNo 44+d13 = opRegNo 45+d14 = opRegNo 46+d15 = opRegNo 47+d16 = opRegNo 48+d17 = opRegNo 49+d18 = opRegNo 50+d19 = opRegNo 51+d20 = opRegNo 52+d21 = opRegNo 53+d22 = opRegNo 54+d23 = opRegNo 55+d24 = opRegNo 56+d25 = opRegNo 57+d26 = opRegNo 58+d27 = opRegNo 59+d28 = opRegNo 60+d29 = opRegNo 61+d30 = opRegNo 62+d31 = opRegNo 63++fitsInNbits :: Int -> Int -> Bool+fitsInNbits n i = (-1 `shiftL` (n - 1)) <= i && i <= (1 `shiftL` (n - 1) - 1)++isUnsignOp :: Int -> Bool+isUnsignOp i = (i >= 0)++isNbitEncodeable :: Int -> Integer -> Bool+isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)++isEncodeableInWidth :: Width -> Integer -> Bool+isEncodeableInWidth = isNbitEncodeable . widthInBits++isIntOp :: Operand -> Bool+isIntOp = not . isFloatOp++isFloatOp :: Operand -> Bool+isFloatOp (OpReg _ reg) | isFloatReg reg = True+isFloatOp _ = False++isFloatReg :: Reg -> Bool+isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True+isFloatReg (RegVirtual (VirtualRegD _)) = True+isFloatReg _ = False++widthToInt :: Width -> Int+widthToInt W8   = 8+widthToInt W16  = 16+widthToInt W32  = 32+widthToInt W64  = 64+widthToInt _ = 64++widthFromOpReg :: Operand -> Width+widthFromOpReg (OpReg W8 _)  = W8+widthFromOpReg (OpReg W16 _) = W16+widthFromOpReg (OpReg W32 _) = W32+widthFromOpReg (OpReg W64 _) = W64+widthFromOpReg _ = W64++ldFormat :: Format -> Format+ldFormat f+  | f `elem` [II8, II16, II32, II64] = II64+  | f `elem` [FF32, FF64] = FF64+  | otherwise = pprPanic "unsupported ldFormat: " (text $ show f)
+ compiler/GHC/CmmToAsm/LA64/Ppr.hs view
@@ -0,0 +1,1149 @@+module GHC.CmmToAsm.LA64.Ppr (pprNatCmmDecl, pprInstr) where++import GHC.Prelude hiding (EQ)++import GHC.CmmToAsm.LA64.Regs+import GHC.CmmToAsm.LA64.Instr+import GHC.CmmToAsm.LA64.Cond+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.Platform+import GHC.Platform.Reg+import GHC.Types.Unique ( pprUniqueAlways, getUnique )+import GHC.Utils.Outputable+import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment)+import GHC.Utils.Panic++pprNatCmmDecl :: forall doc. (IsDoc doc) => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc++pprNatCmmDecl config (CmmData section dats) =+  pprSectionAlign config section $$ pprDatas config dats++pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config++      pprProcAlignment :: doc+      pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config)+   in pprProcAlignment+        $$ case topInfoTable proc of+          Nothing ->+            -- special case for code without info table:+            pprSectionAlign config (Section Text lbl)+              $$+              -- do not+              -- pprProcAlignment config $$+              pprLabel platform lbl+              $$ vcat (map (pprBasicBlock config top_info) blocks) -- blocks guaranteed not null, so label needed+              $$ ppWhen+                (ncgDwarfEnabled config)+                (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl))+              $$ pprSizeDecl platform lbl+          Just (CmmStaticsRaw info_lbl _) ->+            pprSectionAlign config (Section Text info_lbl)+              $$+              -- pprProcAlignment config $$+              ( if platformHasSubsectionsViaSymbols platform+                  then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')+                  else empty+              )+              $$ vcat (map (pprBasicBlock config top_info) blocks)+              $$ ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl))+              $$+              -- above: Even the first block gets a label, because with branch-chain+              -- elimination, it might be the target of a goto.+              ( if platformHasSubsectionsViaSymbols platform+                  then -- See Note [Subsections Via Symbols]++                    line+                      $ text "\t.long "+                      <+> pprAsmLabel platform info_lbl+                      <+> char '-'+                      <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)+                  else empty+              )+              $$ pprSizeDecl platform info_lbl+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure+                -> doc+pprProcEndLabel platform lbl =+    pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon++pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name+                 -> doc+pprBlockEndLabel platform lbl =+    pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon++pprLabel :: IsDoc doc => Platform -> CLabel -> doc+pprLabel platform lbl =+   pprGloblDecl platform lbl+   $$ pprTypeDecl platform lbl+   $$ line (pprAsmLabel platform lbl <> char ':')++pprAlign :: (IsDoc doc) => Alignment -> doc+pprAlign alignment =+  -- .balign is stable, whereas .align is platform dependent.+  line $ text "\t.balign " <> int (alignmentBytes alignment)++-- | Print appropriate alignment for the given section type.+--+-- Currently, this always aligns to a full machine word (8 byte.) A future+-- improvement could be to really do this per section type (though, it's+-- probably not a big gain.)+pprAlignForSection :: (IsDoc doc) => SectionType -> doc+pprAlignForSection _seg = pprAlign . mkAlignment $ 8++-- Print section header and appropriate alignment for that section.+-- This will e.g. emit a header like:+--+--     .section .text+--     .balign 8+--+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc+pprSectionAlign _config (Section (OtherSection _) _) =+  panic "LA64.Ppr.pprSectionAlign: unknown section"+pprSectionAlign config sec@(Section seg _) =+    line (pprSectionHeader config sec)+    $$ pprAlignForSection seg++-- | Output the ELF .size directive+pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc+pprSizeDecl platform lbl+  | osElfTarget (platformOS platform) =+      line $ text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl+pprSizeDecl _ _ = empty++pprBasicBlock ::+  (IsDoc doc) =>+  NCGConfig ->+  LabelMap RawCmmStatics ->+  NatBasicBlock Instr ->+  doc++pprBasicBlock config info_env (BasicBlock blockid instrs)+  = maybe_infotable $+    pprLabel platform asmLbl $$+    vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$+    ppWhen (ncgDwarfEnabled config) (+      -- Emit both end labels since this may end up being a standalone+      -- top-level block+      line (pprBlockEndLabel platform asmLbl+         <> pprProcEndLabel platform asmLbl)+    )+  where+    -- Filter out identity moves. E.g. mov x18, x18 will be dropped.+    optInstrs = filter f instrs+      where f (MOV o1 o2) | o1 == o2 = False+            f _ = True++    asmLbl = blockLbl blockid+    platform = ncgPlatform config+    maybe_infotable c = case mapLookup blockid info_env of+       Nothing   -> c+       Just (CmmStaticsRaw info_lbl info) ->+          --  pprAlignForSection platform Text $$+           infoTableLoc $$+           vcat (map (pprData config) info) $$+           pprLabel platform info_lbl $$+           c $$+           ppWhen (ncgDwarfEnabled config)+              (line (pprBlockEndLabel platform info_lbl))+    -- Make sure the info table has the right .loc for the block+    -- coming right after it. See Note [Info Offset]+    infoTableLoc = case instrs of+      (l@LOCATION{} : _) -> pprInstr platform l+      _other             -> empty++pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl (ncgPlatform config) alias+    $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')++pprDatas config (CmmStaticsRaw lbl dats)+  = vcat (pprLabel platform lbl : map (pprData config) dats)+   where+      platform = ncgPlatform config++pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc+pprData _config (CmmString str) = line (pprString str)+pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)++pprData config (CmmUninitialised bytes)+ = line $ let platform = ncgPlatform config+          in if platformOS platform == OSDarwin+                then text ".space " <> int bytes+                else text ".skip "  <> int bytes++pprData config (CmmStaticLit lit) = pprDataItem config lit++pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc+pprGloblDecl platform lbl+  | not (externallyVisibleCLabel lbl) = empty+  | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl)++-- Always use objects for info tables+--+-- See discussion in X86.Ppr for why this is necessary.  Essentially we need to+-- ensure that we never pass function symbols when we might want to lookup the+-- info table.  If we did, we could end up with procedure linking tables+-- (PLT)s, and thus the lookup wouldn't point to the function, but into the+-- jump table.+--+-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as+-- well.+pprLabelType' :: IsLine doc => Platform -> CLabel -> doc+pprLabelType' platform lbl =+  if isCFunctionLabel lbl || functionOkInfoTable+    then text "@function"+    else text "@object"+  where+    functionOkInfoTable = platformTablesNextToCode platform &&+      isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)++-- this is called pprTypeAndSizeDecl in PPC.Ppr+pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc+pprTypeDecl platform lbl+    = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl+      then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)+      else empty++pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc+pprDataItem config lit+  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+    where+        platform = ncgPlatform config++        imm = litToImm lit++        ppr_item II8  _ = [text "\t.byte\t"  <> pprDataImm platform imm]+        ppr_item II16 _ = [text "\t.short\t" <> pprDataImm platform imm]+        ppr_item II32 _ = [text "\t.long\t"  <> pprDataImm platform imm]+        ppr_item II64 _ = [text "\t.quad\t"  <> pprDataImm platform imm]++        ppr_item FF32  (CmmFloat r _)+           = let bs = floatToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs++        ppr_item FF64 (CmmFloat r _)+           = let bs = doubleToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs++        ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit)++-- | Pretty print an immediate value in the @data@ section+-- This does not include any checks. We rely on the Assembler to check for+-- errors. Use `pprOpImm` for immediates in instructions (operands.)+pprDataImm :: IsLine doc => Platform -> Imm -> doc+pprDataImm _ (ImmInt i)     = int i+pprDataImm _ (ImmInteger i) = integer i+pprDataImm p (ImmCLbl l)    = pprAsmLabel p l+pprDataImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i+pprDataImm _ (ImmLit s)     = ftext s+pprDataImm _ (ImmFloat f) = float (fromRational f)+pprDataImm _ (ImmDouble d) = double (fromRational d)++pprDataImm p (ImmConstantSum a b) = pprDataImm p a <> char '+' <> pprDataImm p b+pprDataImm p (ImmConstantDiff a b) = pprDataImm p a <> char '-'+                   <> lparen <> pprDataImm p b <> rparen++asmComment :: SDoc -> SDoc+asmComment c = text "#" <+> c++asmDoubleslashComment :: SDoc -> SDoc+asmDoubleslashComment c = text "//" <+> c++asmMultilineComment :: SDoc -> SDoc+asmMultilineComment c =  text "/*" $+$ c $+$ text "*/"++-- | Pretty print an immediate operand of an instruction+pprOpImm :: (IsLine doc) => Platform -> Imm -> doc+pprOpImm platform imm = case imm of+  ImmInt i -> int i+  ImmInteger i -> integer i+  ImmCLbl l -> char '=' <> pprAsmLabel platform l+  ImmFloat f -> float (fromRational f)+  ImmDouble d -> double (fromRational d)+  _ -> pprPanic "LA64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands:" <+> (text . show) imm)++negOp :: Operand -> Operand+negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i))+negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i))+negOp op = pprPanic "LA64.negOp" (text $ show op)++pprOp :: IsLine doc => Platform -> Operand -> doc+pprOp plat op = case op of+  OpReg w r                 -> pprReg w r+  OpImm imm                 -> pprOpImm plat imm+  OpAddr (AddrRegReg r1 r2) -> pprReg W64 r1 <> comma <+> pprReg W64 r2+  OpAddr (AddrRegImm r imm) -> pprReg W64 r <> comma <+> pprOpImm plat imm+  OpAddr (AddrReg r)        -> pprReg W64 r <+> text ", 0"++pprReg :: forall doc. IsLine doc => Width -> Reg -> doc+pprReg w r = case r of+  RegReal    (RealRegSingle i) -> ppr_reg_no i+  -- virtual regs should not show up, but this is helpful for debugging.+  RegVirtual (VirtualRegI u)   -> text "%vI_" <> pprUniqueAlways u+  -- RegVirtual (VirtualRegF u)   -> text "%vF_" <> pprUniqueAlways u+  RegVirtual (VirtualRegD u)   -> text "%vD_" <> pprUniqueAlways u+  _                            -> pprPanic "LA64.pprReg" (text (show r) <+> ppr w)++  where+    ppr_reg_no :: Int -> doc+    -- LoongArch's registers must be started from `$[fr]`+    -- General Purpose Registers+    ppr_reg_no 0  = text "$zero"+    ppr_reg_no 1  = text "$ra"+    ppr_reg_no 2  = text "$tp"+    ppr_reg_no 3  = text "$sp"+    ppr_reg_no 4  = text "$a0"+    ppr_reg_no 5  = text "$a1"+    ppr_reg_no 6  = text "$a2"+    ppr_reg_no 7  = text "$a3"+    ppr_reg_no 8  = text "$a4"+    ppr_reg_no 9  = text "$a5"+    ppr_reg_no 10 = text "$a6"+    ppr_reg_no 11 = text "$a7"+    ppr_reg_no 12 = text "$t0"+    ppr_reg_no 13 = text "$t1"+    ppr_reg_no 14 = text "$t2"+    ppr_reg_no 15 = text "$t3"+    ppr_reg_no 16 = text "$t4"+    ppr_reg_no 17 = text "$t5"+    ppr_reg_no 18 = text "$t6"+    ppr_reg_no 19 = text "$t7"+    ppr_reg_no 20 = text "$t8"+    ppr_reg_no 21 = text "$u0"  -- Reserverd+    ppr_reg_no 22 = text "$fp"+    ppr_reg_no 23 = text "$s0"+    ppr_reg_no 24 = text "$s1"+    ppr_reg_no 25 = text "$s2"+    ppr_reg_no 26 = text "$s3"+    ppr_reg_no 27 = text "$s4"+    ppr_reg_no 28 = text "$s5"+    ppr_reg_no 29 = text "$s6"+    ppr_reg_no 30 = text "$s7"+    ppr_reg_no 31 = text "$s8"++    -- Floating Point Registers+    ppr_reg_no 32 = text "$fa0"+    ppr_reg_no 33 = text "$fa1"+    ppr_reg_no 34 = text "$fa2"+    ppr_reg_no 35 = text "$fa3"+    ppr_reg_no 36 = text "$fa4"+    ppr_reg_no 37 = text "$fa5"+    ppr_reg_no 38 = text "$fa6"+    ppr_reg_no 39 = text "$fa7"+    ppr_reg_no 40 = text "$ft0"+    ppr_reg_no 41 = text "$ft1"+    ppr_reg_no 42 = text "$ft2"+    ppr_reg_no 43 = text "$ft3"+    ppr_reg_no 44 = text "$ft4"+    ppr_reg_no 45 = text "$ft5"+    ppr_reg_no 46 = text "$ft6"+    ppr_reg_no 47 = text "$ft7"+    ppr_reg_no 48 = text "$ft8"+    ppr_reg_no 49 = text "$ft9"+    ppr_reg_no 50 = text "$ft10"+    ppr_reg_no 51 = text "$ft11"+    ppr_reg_no 52 = text "$ft12"+    ppr_reg_no 53 = text "$ft13"+    ppr_reg_no 54 = text "$ft14"+    ppr_reg_no 55 = text "$ft15"+    ppr_reg_no 56 = text "$fs0"+    ppr_reg_no 57 = text "$fs1"+    ppr_reg_no 58 = text "$fs2"+    ppr_reg_no 59 = text "$fs3"+    ppr_reg_no 60 = text "$fs4"+    ppr_reg_no 61 = text "$fs5"+    ppr_reg_no 62 = text "$fs6"+    ppr_reg_no 63 = text "$fs7"++    ppr_reg_no i+         | i < 0 = pprPanic "Unexpected register number (min is 0)" (ppr w <+> int i)+         | i > 63 = pprPanic "Unexpected register number (max is 63)" (ppr w <+> int i)+         -- no support for widths > W64.+         | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i)++-- | Single precission `Operand` (floating-point)+isSingleOp :: Operand -> Bool+isSingleOp (OpReg W32 _) = True+isSingleOp _ = False++-- | Double precission `Operand` (floating-point)+isDoubleOp :: Operand -> Bool+isDoubleOp (OpReg W64 _) = True+isDoubleOp _ = False++-- | `Operand` is an immediate value+isImmOp :: Operand -> Bool+isImmOp (OpImm _) = True+isImmOp _ = False++-- | `Operand` is an immediate @0@ value+isImmZero :: Operand -> Bool+isImmZero (OpImm (ImmFloat 0)) = True+isImmZero (OpImm (ImmDouble 0)) = True+isImmZero (OpImm (ImmInt 0)) = True+isImmZero _ = False++pprInstr :: IsDoc doc => Platform -> Instr -> doc+pprInstr platform instr = case instr of+  -- Meta Instructions ---------------------------------------------------------+  -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable+  COMMENT s  -> dualDoc (asmComment s) empty+  MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty+  ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i)++  LOCATION file line' col _name+    -> line (text "\t.loc" <+> int file <+> int line' <+> int col)+  DELTA d   -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty+  NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"+  LDATA _ _ -> panic "PprInstr: NEWBLOCK"++  -- Pseudo Instructions -------------------------------------------------------++  PUSH_STACK_FRAME -> lines_ [ text "\taddi.d $sp, $sp, -16"+                             , text "\tst.d   $ra, $sp, 8"+                             , text "\tst.d   $fp, $sp, 0"+                             , text "\taddi.d $fp, $sp, 16"+                             ]++  POP_STACK_FRAME -> lines_  [ text "\tld.d   $fp, $sp, 0"+                             , text "\tld.d   $ra, $sp, 8"+                             , text "\taddi.d $sp, $sp, 16"+                             ]+++  -- ===========================================================================+  -- LoongArch64 Instruction Set+  -- Basic Integer Instructions ------------------------------------------------+  -- 1. Arithmetic Instructions ------------------------------------------------+    -- ADD.{W/D}, SUB.{W/D}+    -- ADDI.{W/D}, ADDU16I.D+  ADD  o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfadd.s") o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfadd.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tadd.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tadd.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: ADD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- TODO: Not complete.+    -- Here we should add addu16i.d for optimizations of accelerating GOT accession+    -- with ldptr.w/d, stptr.w/d+  SUB  o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfsub.s") o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfsub.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsub.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsub.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 (negOp o3)+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 (negOp o3)+    | otherwise -> pprPanic "LA64.ppr: SUB error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- ALSL.{W[U]/D}+  ALSL  o1 o2 o3 o4+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3, isImmOp o4 -> op4 (text "\talsl.w") o1 o2 o3 o4+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3, isImmOp o4 -> op4 (text "\talsl.d") o1 o2 o3 o4+    | otherwise -> pprPanic "LA64.ppr: ALSL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  ALSLU  o1 o2 o3 o4 -> op4 (text "\talsl.wu") o1 o2 o3 o4+    -- LoongArch-Assembler should implement following pesudo instructions, here we can directly use them.+    -- li.w rd, s32+    -- li.w rd, u32+    -- li.d rd, s64+    -- li.d rd, u64+    --+    -- # Load with one instruction+    -- ori dst, $zero, imm[11:0]+    --+    -- # Load with two instructions+    -- lu12i.w dst, imm[31:12]+    -- ori     dst, dst, imm[11:0]+    --+    -- # Load with four instructions+    -- lu12i.w dst, imm[31:12]+    -- ori     dst, dst, imm[11:0]+    -- lu32i.d dst, imm[51:32]+    -- lu52i.d dst, dst, imm[63:52]++  --  -- LU12I.W, LU32I.D, LU52I.D+  LU12I  o1 o2 -> op2 (text "\tlu12i.w") o1 o2+  LU32I  o1 o2 -> op2 (text "\tlu32i.d") o1 o2+  LU52I  o1 o2 o3 -> op3 (text "\tlu52i.d") o1 o2 o3+    -- SSLT[U]+    -- SSLT[U]I+  SSLT  o1 o2 o3+    | isImmOp o3 -> op3 (text "\tslti") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3  -> op3 (text "\tslt") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: SSLT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  SSLTU  o1 o2 o3+    | isImmOp o3 -> op3 (text "\tsltui") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsltu") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: SSLTU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- PCADDI, PCADDU121, PCADDU18l, PCALAU12I+  PCADDI  o1 o2     -> op2 (text "\tpcaddi") o1 o2+  PCADDU12I  o1 o2  -> op2 (text "\tpcaddu12i") o1 o2+  PCADDU18I  o1 (OpImm (ImmCLbl lbl))  ->+    lines_ [+      text "\tpcaddu18i" <+> pprOp platform o1 <> comma <+> text "%call36(" <+> pprAsmLabel platform lbl <+> text ")"+           ]+  PCALAU12I  o1 o2  -> op2 (text "\tpcalau12i") o1 o2+    -- AND, OR, NOR, XOR, ANDN, ORN+    -- ANDI, ORI, XORI: zero-extention+  AND  o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tand") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tandi") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: AND error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  OR  o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tor") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tori") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: OR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  XOR  o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\txor") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\txori") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: XOR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  NOR  o1 o2 o3   -> op3 (text "\tnor") o1 o2 o3+  ANDN  o1 o2 o3  -> op3 (text "\tandn") o1 o2 o3+  ORN  o1 o2 o3   -> op3 (text "\torn") o1 o2 o3++  -----------------------------------------------------------------------------+  -- Pseudo instructions+  -- NOP, alias for "andi r0, r0, r0"+  NOP -> line $ text "\tnop"+  -- NEG o1 o2, alias for "sub o1, r0, o2"+  NEG o1 o2+    | isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2+    | isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2+    | OpReg W32 _ <- o2 -> op3 (text "\tsub.w" ) o1 zero o2+    | OpReg W64 _ <- o2 -> op3 (text "\tsub.d" ) o1 zero o2+    | otherwise -> pprPanic "LA64.ppr: NEG error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)+  -- Here we can do more simplitcations.+  -- To be honest, floating point instructions are too scarce, so maybe+  -- we should reimplement some pseudo instructions with others.+  MOV o1 o2+    | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> op2 (text "\tfmov.s") o1 o2+    | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> op2 (text "\tfmov.d") o1 o2+    | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 zero+    | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 zero+    | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 o2+    | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tmovfr2gr.s") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tmovfr2gr.d") o1 o2+    | isImmOp o2, (OpImm (ImmInt i)) <- o2, fitsInNbits 12 (fromIntegral i) ->+      lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2]+    | isImmOp o2, (OpImm (ImmInteger i)) <- o2, fitsInNbits 12 (fromIntegral i) ->+      lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2]+    | OpReg W64 _ <- o2 -> op2 (text "\tmove") o1 o2+    | OpReg _ _ <- o2  ->+      lines_ [+        text "\tbstrpick.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform (OpImm (ImmInt ((widthToInt (min (widthFromOpReg o1) (widthFromOpReg o2))) - 1))) <+> text ", 0"+             ]+    -- TODO: Maybe we can do more.+    -- Let the assembler do these concret things.+    | isImmOp o2 ->+      lines_ [text "\tli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2]+    | otherwise -> pprPanic "LA64.ppr: MOV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++  -- CSET pesudo instrcutions implementation+  CSET cond dst o1 o2 -> case cond of+    -- SEQ dst, rd, rs -> [SUB rd, rd, rs;  sltui dst, rd, 1]+    EQ | isIntOp o1 && isIntOp o2 ->+      lines_ [+              subFor o1 o2,+              text "\tsltui" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    EQ | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.seq.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    EQ | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.seq.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    -- SNE rd, rs -> [SUB rd, rd, rs;   sltu rd, zero, rs]+    NE | isIntOp o1 && isIntOp o2 ->+      lines_ [+              subFor o1 o2,+              text "\tsltu" <+> pprOp platform dst <> comma <+> text "$r0" <+> comma <+> pprOp platform dst+             ]+    NE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.cune.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    NE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.cune.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    SLT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ]+    -- SLE rd, rs -> [SLT rd, rs;  xori rd, rs, o1]+    SLE ->+      lines_ [+              sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\txori" <+>  pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- SGE rd, rs -> [SLT rd, rs;  xori rd, rs, o1]+    SGE ->+      lines_ [+              sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\txori" <+>  pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- SGT rd, rs -> [SLT rd, rs]+    SGT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ]++    ULT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ]+    ULE ->+      lines_ [+              sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- UGE rd, rs -> [SLTU rd, rs;  xori rd, rs, 1]+    UGE ->+      lines_ [+              sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\txori" <+>  pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- SGTU rd, rs -> [SLTU rd, rs]+    UGT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ]++    -- TODO:+    -- LoongArch's floating point instrcutions don't write the compared result to an interger register, instead of cc.+    -- Fcond dst o1 o2 -> [fcmp.cond.[s/d] fcc0 o1 o2;  movcf2gr dst, fcc0]+    FLT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.slt.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FLE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.sle.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.slt.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.sle.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]++    FLT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.slt.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FLE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.sle.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.slt.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.sle.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]++    _ -> pprPanic "LA64.ppr: CSET error: " (pprCond cond <+> pprOp platform dst <> comma <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++    where+      subFor o1 o2  | (OpReg W64 _) <- dst, (OpImm _) <- o2  =+                        text "\taddi.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform (negOp o2)+                    | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 =+                        text "\tsub.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2+                    | otherwise = pprPanic "LA64.ppr: unknown subFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++      sltFor o1 o2  | (OpReg W64 _) <- dst, (OpImm _) <- o2   = text "\tslti"+                    | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tslt"+                    | otherwise = pprPanic "LA64.ppr: unknown sltFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++      sltuFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2   = text "\tsltui"+                    | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tsltu"+                    | otherwise = pprPanic "LA64.ppr: unknown sltuFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++    -- MUL.{W/D}, MULH, {W[U]/D[U]}, 'h' means high 32bit.+    -- MULW.D.W[U]+  MUL  o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfmul.s") o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfmul.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmul.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmul.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MUL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULW   o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.w") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULW error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULWU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.wu") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULWU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULH  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o2 -> op3 (text "\tmulh.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULH error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULHU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.wu") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmulh.du") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULHU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- DIV.{W[U]/D[U]}, MOD.{W[U]/D[U]}+  DIV  o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfdiv.s") o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfdiv.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: DIV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  DIVU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.wu") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.du") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: DIVU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MOD  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MOD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MODU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.wu") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.du") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MODU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  -- 2. Bit-shift Instuctions --------------------------------------------------+    -- SLL.W, SRL.W, SRA.W, ROTR.W+    -- SLL.D, SRL.D, SRA.D, ROTR.D+    -- SLLI.W, SRLI.W, SRAI.W, ROTRI.W+    -- SLLI.D, SRLI.D, SRAI.D, ROTRI.D+  SLL  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsll.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsll.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\tslli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\tslli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: SLL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  SRL  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsrl.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsrl.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: SRL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  SRA  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsra.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsra.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrai.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrai.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: SRA error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  ROTR  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\trotr.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\trotr.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\trotri.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\trotri.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: ROTR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  -- 3. Bit-manupulation Instructions ------------------------------------------+    -- EXT.W{B/H}+  EXT o1 o2+    | OpReg W8 _ <- o2  -> op2 (text "\text.w.b") o1 o2+    | OpReg W16 _ <- o2 -> op2 (text "\text.w.h") o1 o2+    | otherwise -> pprPanic "LA64.ppr: EXT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)+    -- CL{O/Z}.{W/D}, CT{O/Z}.{W/D}+  CLO o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tclo.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tclo.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CLO error" (pprOp platform o1 <+> pprOp platform o2)+  CLZ o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tclz.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tclz.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CLZ error" (pprOp platform o1 <+> pprOp platform o2)+  CTO o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tcto.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tcto.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CTO error" (pprOp platform o1 <+> pprOp platform o2)+  CTZ o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tctz.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tctz.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CTZ error" (pprOp platform o1 <+> pprOp platform o2)+    -- BYTEPICK.{W/D} rd, rj, rk, sa2/sa3+  BYTEPICK o1 o2 o3 o4+    | OpReg W32 _ <- o2 -> op4 (text "\tbytepick.w") o1 o2 o3 o4+    | OpReg W64 _ <- o2 -> op4 (text "\tbytepick.d") o1 o2 o3 o4+    | otherwise -> pprPanic "LA64.ppr: BYTEPICK error" (pprOp platform o1 <+> pprOp platform o2 <+> pprOp platform o3 <+> pprOp platform o4)+    -- REVB.{2H/4H/2W/D}+  REVB2H o1 o2 -> op2 (text "\trevb.2h") o1 o2+  REVB4H o1 o2 -> op2 (text "\trevb.4h") o1 o2+  REVB2W o1 o2 -> op2 (text "\trevb.2w") o1 o2+  REVBD  o1 o2 -> op2 (text "\trevb.d") o1 o2+    -- REVH.{2W/D}+  REVH2W o1 o2 -> op2 (text "\trevh.2w") o1 o2+  REVHD o1 o2 -> op2 (text "\trevh.d") o1 o2+    -- BITREV.{4B/8B}+    -- BITREV.{W/D}+  BITREV4B o1 o2 -> op2 (text "\tbitrev.4b") o1 o2+  BITREV8B o1 o2 -> op2 (text "\tbitrev.8b") o1 o2+  BITREVW o1 o2 -> op2 (text "\tbitrev.w") o1 o2+  BITREVD o1 o2 -> op2 (text "\tbitrev.d") o1 o2+    -- BSTRINS.{W/D}+  BSTRINS II64 o1 o2 o3 o4 -> op4 (text "\tbstrins.d") o1 o2 o3 o4+  BSTRINS II32 o1 o2 o3 o4 -> op4 (text "\tbstrins.w") o1 o2 o3 o4+    -- BSTRPICK.{W/D}+  BSTRPICK II64 o1 o2 o3 o4 -> op4 (text "\tbstrpick.d") o1 o2 o3 o4+  BSTRPICK II32 o1 o2 o3 o4 -> op4 (text "\tbstrpick.w") o1 o2 o3 o4+    -- MASKEQZ rd, rj, rk:  if rk == 0 ? rd = 0 : rd = rj+  MASKEQZ o1 o2 o3 -> op3 (text "\tmaskeqz") o1 o2 o3+    -- MASKNEZ:  if rk == 0 ? rd = 0 : rd = rj+  MASKNEZ o1 o2 o3 -> op3 (text "\tmasknez") o1 o2 o3+  -- 4. Branch Instructions ----------------------------------------------------+    -- BEQ, BNE, BLT[U], BGE[U]   rj, rd, off16+    -- BEQZ, BNEZ   rj, off21+    -- B+    -- BL+    -- JIRL+    -- jr rd = jirl $zero, rd, 0: Commonly used for subroutine return.+  J (TReg r) -> line $ text "\tjirl" <+> text "$r0" <> comma <+> pprReg W64 r <> comma <+> text " 0"+  J_TBL _ _ r    -> pprInstr platform (B (TReg r))++  B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl+  B (TReg r)     -> line $ text "\tjr" <+> pprReg W64 r++  BL (TBlock bid) _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl+  BL (TReg r) _    -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0"++  CALL (TBlock bid) _ -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  CALL (TLabel lbl) _ -> line $ text "\tcall36" <+> pprAsmLabel platform lbl+  CALL (TReg r) _ -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0"++  CALL36 (TBlock bid) -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  CALL36 (TLabel lbl) -> line $ text "\tcall36" <+> pprAsmLabel platform lbl+  CALL36 _ -> panic "LA64.ppr: CALL36: Not to registers!"+  TAIL36 r (TBlock bid) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  TAIL36 r (TLabel lbl) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform lbl+  TAIL36 _ _ -> panic "LA64.ppr: TAIL36: Not to registers!"++  BCOND1 c j d (TBlock bid) -> case c of+    SLE ->+      line $ text "\tbge" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    SGT ->+      line $ text "\tblt" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    ULE ->+      line $ text "\tbgeu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    UGT ->+      line $ text "\tbltu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    _ -> line $ text "\t" <> pprBcond c <+> pprOp platform j <> comma <+> pprOp platform d <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))++  BCOND1 _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND1: No conditional branching to TLabel!"++  BCOND1 _ _ _ (TReg _) -> panic "LA64.ppr: BCOND1: No conditional branching to registers!"++  -- Reuse t8(IP) register+  BCOND c j d (TBlock bid) -> case c of+    SLE ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    SGT ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    ULE ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    UGT ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    EQ ->+      lines_ [+              text "\tsub.d $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    NE ->+      lines_ [+              text "\tsub.d $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    SLT ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    SGE ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    ULT ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    UGE ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    _ -> panic "LA64.ppr: BCOND: Unsupported cond!"++  BCOND _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND: No conditional branching to TLabel!"++  BCOND _ _ _ (TReg _) -> panic "LA64.ppr: BCOND: No conditional branching to registers!"++  BEQZ j (TBlock bid) ->+    line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BEQZ j (TLabel lbl) ->+    line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl+  BEQZ _ (TReg _)     -> panic "LA64.ppr: BEQZ: No conditional branching to registers!"++  BNEZ j (TBlock bid) ->+    line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BNEZ j (TLabel lbl) ->+    line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl+  BNEZ _ (TReg _)     -> panic "LA64.ppr: BNEZ: No conditional branching to registers!"++  -- 5. Common Memory Access Instructions --------------------------------------+    -- LD.{B[U]/H[U]/W[U]/D}, ST.{B/H/W/D}: AddrRegImm+    -- LD: load, ST: store, x: offset in register, u: load unsigned imm.+    -- LD format dst src: 'src' means final address, not single register or immdiate.+  -- Load symbol's address+  LD _fmt o1 (OpImm (ImmIndex lbl' off)) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+           ]+  LD _fmt o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+           ]+  LD _fmt o1 (OpImm (ImmIndex lbl off)) ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"    <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+           ]++  LD _fmt o1 (OpImm (ImmCLbl lbl')) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+           ]+  LD _fmt o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+           ]+  LD _fmt o1 (OpImm (ImmCLbl lbl)) ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"    <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+           ]++  LD II8  o1 o2 -> op2 (text "\tld.b") o1 o2+  LD II16 o1 o2 -> op2 (text "\tld.h") o1 o2+  LD II32 o1 o2 -> op2 (text "\tld.w") o1 o2+  LD II64 o1 o2 -> op2 (text "\tld.d") o1 o2+  LD FF32 o1 o2 -> op2 (text "\tfld.s") o1 o2+  LD FF64 o1 o2 -> op2 (text "\tfld.d") o1 o2++  LDU II8  o1 o2 -> op2 (text "\tld.bu") o1 o2+  LDU II16 o1 o2 -> op2 (text "\tld.hu") o1 o2+  LDU II32 o1 o2 -> op2 (text "\tld.wu") o1 o2+  LDU II64 o1 o2 -> op2 (text "\tld.d") o1 o2   -- double words (64bit) cannot be sign extended by definition+  LDU FF32 o1 o2@(OpAddr (AddrReg _))       -> op2 (text "\tfld.s") o1 o2+  LDU FF32 o1 o2@(OpAddr (AddrRegImm _ _))  -> op2 (text "\tfld.s") o1 o2+  LDU FF64 o1 o2@(OpAddr (AddrReg _))       -> op2 (text "\tfld.d") o1 o2+  LDU FF64 o1 o2@(OpAddr (AddrRegImm _ _))  -> op2 (text "\tfld.d") o1 o2+  LDU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text.show) f <+> pprOp platform o1 <+> pprOp platform o2)++  ST II8  o1 o2 -> op2 (text "\tst.b") o1 o2+  ST II16 o1 o2 -> op2 (text "\tst.h") o1 o2+  ST II32 o1 o2 -> op2 (text "\tst.w") o1 o2+  ST II64 o1 o2 -> op2 (text "\tst.d") o1 o2+  ST FF32 o1 o2 -> op2 (text "\tfst.s") o1 o2+  ST FF64 o1 o2 -> op2 (text "\tfst.d") o1 o2++    -- LDPTR.{W/D}, STPTR.{W/D}: AddrRegImm: AddrRegImm+  LDPTR II32 o1 o2 -> op2 (text "\tldptr.w") o1 o2+  LDPTR II64 o1 o2 -> op2 (text "\tldptr.d") o1 o2+  STPTR II32 o1 o2 -> op2 (text "\tstptr.w") o1 o2+  STPTR II64 o1 o2 -> op2 (text "\tstptr.d") o1 o2++    -- LDX.{B[U]/H[U]/W[U]/D}, STX.{B/H/W/D}: AddrRegReg+  LDX II8   o1 o2 -> op2 (text "\tldx.b")  o1 o2+  LDX II16  o1 o2 -> op2 (text "\tldx.h")  o1 o2+  LDX II32  o1 o2 -> op2 (text "\tldx.w")  o1 o2+  LDX II64  o1 o2 -> op2 (text "\tldx.d")  o1 o2+  LDX FF32  o1 o2 -> op2 (text "\tfldx.s") o1 o2+  LDX FF64  o1 o2 -> op2 (text "\tfldx.d") o1 o2+  LDXU II8  o1 o2 -> op2 (text "\tldx.bu") o1 o2+  LDXU II16 o1 o2 -> op2 (text "\tldx.hu") o1 o2+  LDXU II32 o1 o2 -> op2 (text "\tldx.wu") o1 o2+  LDXU II64 o1 o2 -> op2 (text "\tldx.d")  o1 o2+  STX II8   o1 o2 -> op2 (text "\tstx.b")  o1 o2+  STX II16  o1 o2 -> op2 (text "\tstx.h")  o1 o2+  STX II32  o1 o2 -> op2 (text "\tstx.w")  o1 o2+  STX II64  o1 o2 -> op2 (text "\tstx.d")  o1 o2+  STX FF32  o1 o2 -> op2 (text "\tfstx.s") o1 o2+  STX FF64  o1 o2 -> op2 (text "\tfstx.d") o1 o2++  PRELD h o1@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tpreld") h o1+  -- 6. Bound Check Memory Access Instructions ---------------------------------+    -- LD{GT/LE}.{B/H/W/D}, ST{GT/LE}.{B/H/W/D}+  -- 7. Atomic Memory Access Instructions --------------------------------------+    -- AM{SWAP/ADD/AND/OR/XOR/MAX/MIN}[DB].{W/D}, AM{MAX/MIN}[_DB].{WU/DU}+    -- AM.{SWAP/ADD}[_DB].{B/H}+    -- AMCAS[_DB].{B/H/W/D}+    -- LL.{W/D}, SC.{W/D}+    -- SC.Q+    -- LL.ACQ.{W/D}, SC.REL.{W/D}+  -- 8. Barrier Instructions ---------------------------------------------------+    -- DBAR, IBAR+  DBAR h -> line $ text "\tdbar" <+> pprBarrierType h+  IBAR h -> line $ text "\tibar" <+> pprBarrierType h++    -- Floating-point convert precision+  FCVT o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2+  FCVT o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2+  FCVT o1 o2 -> pprPanic "LA64.pprInstr - impossible float conversion" $+                  line (pprOp platform o1 <> text "->" <> pprOp platform o2)+    -- Signed fixed-point convert to floating-point+    -- For LoongArch, ffint.* instructions's second operand must be float-pointing register,+    -- so we need one more operation.+    -- Also to tfint.*.+  SCVTF o1@(OpReg W32 _) o2@(OpReg W32 _) -> lines_+    [+      text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.s.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1@(OpReg W32 _) o2@(OpReg W64 _) -> lines_+    [+      text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.s.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1@(OpReg W64 _) o2@(OpReg W32 _) -> lines_+    [+      text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.d.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1@(OpReg W64 _) o2@(OpReg W64 _) -> lines_+    [+      text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.d.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1 o2 -> pprPanic "LA64.pprInstr - impossible integer to float conversion" $+                  line (pprOp platform o1 <> text "->" <> pprOp platform o2)++    -- Floating-point convert to signed integer, rounding toward zero+    -- TODO: FCVTZS will destroy src-floating register if the previous opertion+    -- includes this reg. So I'm just stupidly saving and restoring by adding+    -- an extra register.+  FCVTZS o1@(OpReg W32 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_+    [+      text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.w.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1@(OpReg W32 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_+    [+      text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.w.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1@(OpReg W64 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_+    [+      text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.l.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1@(OpReg W64 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_+    [+      text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.l.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.d" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1 o2 o3 -> pprPanic "LA64.pprInstr - impossible float to integer conversion" $+                   line (pprOp platform o3 <> text "->" <+> pprOp platform o1 <+> text "tmpReg:" <+> pprOp platform o2)++  FMIN o1 o2 o3  -> op3 (text "fmin." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FMINA o1 o2 o3 -> op3 (text "fmina." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FMAX o1 o2 o3  -> op3 (text "fmax." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FMAXA o1 o2 o3 -> op3 (text "fmaxa." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FABS o1 o2 -> op2 (text "fabs." <> if isSingleOp o2 then text "s" else text "d") o1 o2+  FNEG o1 o2 -> op2 (text "fneg." <> if isSingleOp o2 then text "s" else text "d") o1 o2+  FSQRT o1 o2 -> op2 (text "fsqrt." <> if isSingleOp o2 then text "s" else text "d") o1 o2+  FMA variant d o1 o2 o3 ->+    let fma = case variant of+                FMAdd   -> text "\tfmadd." <+> floatPrecission d+                FMSub   -> text "\tfmsub." <+> floatPrecission d+                FNMAdd  -> text "\tfnmadd." <+> floatPrecission d+                FNMSub  -> text "\tfnmsub." <+> floatPrecission d+    in op4 fma d o1 o2 o3++  instr -> panic $ "LA64.pprInstr - Unknown instruction: " ++ (instrCon instr)+  where op2 op o1 o2        = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2+        op3 op o1 o2 o3     = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+        op4 op o1 o2 o3 o4  = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+{-+    -- TODO: Support dbar with different hints.+    On LoongArch uses "dbar 0" (full completion barrier) for everything.+    But the full completion barrier has no performance to tell, so+    Loongson-3A6000 and newer processors have made finer granularity hints+    available:++    Bit4: ordering or completion (0: completion, 1: ordering)+    Bit3: barrier for previous read (0: true, 1: false)+    Bit2: barrier for previous write (0: true, 1: false)+    Bit1: barrier for succeeding read (0: true, 1: false)+    Bit0: barrier for succeeding write (0: true, 1: false)+-}+        pprBarrierType Hint0 = text "0x0"+        floatPrecission o | isSingleOp o = text "s"+                          | isDoubleOp o = text "d"+                          | otherwise  = pprPanic "Impossible floating point precission: " (pprOp platform o)++-- LoongArch64 Conditional Branch Instructions+pprBcond :: IsLine doc => Cond -> doc+pprBcond c = text "b" <> pprCond c++pprCond :: IsLine doc => Cond -> doc+pprCond c = case c of+      EQ -> text "eq"     -- beq  rj, rd, off16+      NE -> text "ne"     -- bne  rj, rd, off16+      SLT -> text "lt"    -- blt  rj, rd, off16+      SGE -> text "ge"    -- bge  rj, rd, off16+      ULT -> text "ltu"   -- bltu rj, rd, off16+      UGE -> text "geu"   -- bgeu rj, rd, off16+      -- Following not real instructions, just mark it.+      SLE    -> text "sle->ge"   -- ble  rj, rd, off16 -> bge  rd, rj, off16+      SGT    -> text "sgt->lt"   -- bgt  rj, rd, off16 -> blt  rd, rj, off16+      ULE    -> text "ule->geu"  -- bleu rj, rd, off16 -> bgeu rd, rj, off16+      UGT    -> text "ugt->ltu"  -- bgtu rj, rd, off16 -> bltu rd, rj, off16+      _ -> panic $ "LA64.ppr: non-implemented branch condition: " ++ show c
+ compiler/GHC/CmmToAsm/LA64/RegInfo.hs view
@@ -0,0 +1,25 @@+-- Here maybe have something to be optimized in future?+module GHC.CmmToAsm.LA64.RegInfo where++import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.CmmToAsm.LA64.Instr+import GHC.Prelude+import GHC.Utils.Outputable++newtype JumpDest = DestBlockId BlockId++instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid++getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid++canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing++shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics+shortcutStatics _ other_static = other_static++shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other
+ compiler/GHC/CmmToAsm/LA64/Regs.hs view
@@ -0,0 +1,155 @@+module GHC.CmmToAsm.LA64.Regs where++import GHC.Prelude+import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel )+import GHC.CmmToAsm.Format+import GHC.Data.FastString+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Separate+import GHC.Platform.Regs+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Types.Unique++-- All machine register numbers.+allMachRegNos :: [RegNo]+allMachRegNos = [0..31] ++ [32..63]++zeroReg, raReg, tpMachReg, fpMachReg, spMachReg, tmpReg :: Reg+zeroReg = regSingle 0+raReg = regSingle 1+tpMachReg = regSingle 2+-- Not to be confused with the `CmmReg` `spReg`+spMachReg = regSingle 3+fpMachReg = regSingle 22+-- Use t8(r20) for LA64 IP register.+tmpReg = regSingle 20++-- Registers available to the register allocator.+allocatableRegs :: Platform -> [RealReg]+allocatableRegs platform =+  let isFree = freeReg platform+   in map RealRegSingle $ filter isFree allMachRegNos++-- Integer argument registers according to the calling convention+allGpArgRegs :: [Reg]+allGpArgRegs = map regSingle [4..11]++-- | Floating point argument registers according to the calling convention+allFpArgRegs :: [Reg]+allFpArgRegs = map regSingle [32..39]++-- Addressing modes+data AddrMode+  = AddrRegReg Reg Reg+  | AddrRegImm Reg Imm+  | AddrReg Reg+  deriving (Eq, Show)++-- Immediates+data Imm+  = ImmInt      Int+  | ImmInteger  Integer     -- Sigh.+  | ImmCLbl     CLabel      -- AbstractC Label (with baggage)+  | ImmLit      FastString+  | ImmIndex    CLabel Int+  | ImmFloat    Rational+  | ImmDouble   Rational+  | ImmConstantSum Imm Imm+  | ImmConstantDiff Imm Imm+  deriving (Eq, Show)++-- Map CmmLit to Imm+litToImm :: CmmLit -> Imm+litToImm (CmmInt i w) = ImmInteger (narrowS w i)+-- narrow to the width: a CmmInt might be out of+-- range, but we assume that ImmInteger only contains+-- in-range values.  A signed value should be fine here.+litToImm (CmmFloat f W32) = ImmFloat f+litToImm (CmmFloat f W64) = ImmDouble f+litToImm (CmmLabel l)     = ImmCLbl l+litToImm (CmmLabelOff l off) = ImmIndex l off+litToImm (CmmLabelDiffOff l1 l2 off _) =+  ImmConstantSum+    (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))+    (ImmInt off)+litToImm l = panic $ "LA64.Regs.litToImm: no match for " ++ show l++-- == To satisfy GHC.CmmToAsm.Reg.Target =======================================++-- squeese functions for the graph allocator -----------------------------------+-- | regSqueeze_class reg+--      Calculate the maximum number of register colors that could be+--      denied to a node of this class due to having this reg+--      as a neighbour.+--+{-# INLINE virtualRegSqueeze #-}+virtualRegSqueeze :: RegClass -> VirtualReg -> Int+virtualRegSqueeze cls vr+  = case cls of+    RcInteger ->+      case vr of+        VirtualRegI {} -> 1+        VirtualRegHi {} -> 1+        _other -> 0+    RcFloat ->+      case vr of+        VirtualRegD {} -> 1+        _other -> 0+    RcVector ->+      case vr of+        VirtualRegV128 {} -> 1+        _other -> 0++{-# INLINE realRegSqueeze #-}+realRegSqueeze :: RegClass -> RealReg -> Int+realRegSqueeze cls rr =+  case cls of+    RcInteger ->+      case rr of+        RealRegSingle regNo+          | regNo < 32+          -> 1+          | otherwise+          -> 0+    RcFloat ->+      case rr of+        RealRegSingle regNo+          |  regNo < 32+          || regNo > 63+          -> 0+          | otherwise+          -> 1+    RcVector ->+      case rr of+        RealRegSingle regNo+          | regNo > 63+          -> 1+          | otherwise+          -> 0++mkVirtualReg :: Unique -> Format -> VirtualReg+mkVirtualReg u format+   | not (isFloatFormat format) = VirtualRegI u+   | otherwise+   = case format of+        FF32    -> VirtualRegD u+        FF64    -> VirtualRegD u+        _       -> panic "LA64.mkVirtualReg"++{-# INLINE classOfRealReg #-}+classOfRealReg :: RealReg -> RegClass+classOfRealReg (RealRegSingle i)+   | i < 32 = RcInteger+   | i > 63 = RcVector+   | otherwise = RcFloat++regDotColor :: RealReg -> SDoc+regDotColor reg+ = case classOfRealReg reg of+        RcInteger       -> text "blue"+        RcFloat         -> text "red"+        RcVector        -> text "green"
compiler/GHC/CmmToAsm/PIC.hs view
@@ -137,6 +137,11 @@               addImport symbolPtr               return $ cmmMakePicReference config symbolPtr +        AccessViaSymbolPtr | ArchLoongArch64 <- platformArch platform -> do+              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl+              addImport symbolPtr+              return $ cmmMakePicReference config symbolPtr+         AccessViaSymbolPtr -> do               let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl               addImport symbolPtr@@ -176,6 +181,9 @@    -- as on AArch64, there's no pic base register.   | ArchRISCV64 <- platformArch platform+  = CmmLit $ CmmLabel lbl++  | ArchLoongArch64 <- platformArch platform   = CmmLit $ CmmLabel lbl    | OSAIX <- platformOS platform
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -661,11 +661,7 @@       MO_V_Add {} -> vectorsNeedLlvm       MO_V_Sub {} -> vectorsNeedLlvm       MO_V_Mul {} -> vectorsNeedLlvm-      MO_VS_Quot {} -> vectorsNeedLlvm-      MO_VS_Rem {} -> vectorsNeedLlvm       MO_VS_Neg {} -> vectorsNeedLlvm-      MO_VU_Quot {} -> vectorsNeedLlvm-      MO_VU_Rem {} -> vectorsNeedLlvm       MO_VF_Extract {} -> vectorsNeedLlvm       MO_VF_Add {} -> vectorsNeedLlvm       MO_VF_Sub {} -> vectorsNeedLlvm@@ -2192,6 +2188,14 @@                     MO_AddIntC {}    -> unsupported                     MO_SubIntC {}    -> unsupported                     MO_U_Mul2 {}     -> unsupported+                    MO_VS_Quot {}    -> unsupported+                    MO_VS_Rem {}     -> unsupported+                    MO_VU_Quot {}    -> unsupported+                    MO_VU_Rem {}     -> unsupported+                    MO_I64X2_Min     -> unsupported+                    MO_I64X2_Max     -> unsupported+                    MO_W64X2_Min     -> unsupported+                    MO_W64X2_Max     -> unsupported                     MO_AcquireFence  -> unsupported                     MO_ReleaseFence  -> unsupported                     MO_SeqCstFence   -> unsupported
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- ----------------------------------------------------------------------------- -- -- Machine-dependent assembly language@@ -60,7 +58,7 @@ import Data.Foldable (toList) import qualified Data.List.NonEmpty as NE import GHC.Data.FastString (FastString)-import Data.Maybe (fromMaybe)+import GHC.Data.Maybe (expectJust, fromMaybe)   --------------------------------------------------------------------------------@@ -721,7 +719,7 @@             = BCCFAR cond tgt p             | otherwise             = BCC cond tgt p-            where Just targetAddr = lookupUFM blockAddressMap tgt+            where targetAddr = expectJust $ lookupUFM blockAddressMap tgt         makeFar _ other            = other          -- 8192 instructions are allowed; let's keep some distance, as
compiler/GHC/CmmToAsm/Ppr.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}  -----------------------------------------------------------------------------@@ -40,11 +39,6 @@ import GHC.Exts import GHC.Word -#if !MIN_VERSION_base(4,16,0)-word8ToWord# :: Word# -> Word#-word8ToWord# w = w-{-# INLINE word8ToWord# #-}-#endif  -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing
compiler/GHC/CmmToAsm/RV64/CodeGen.hs view
@@ -1868,6 +1868,14 @@     MO_AddIntC _w -> unsupported mop     MO_SubIntC _w -> unsupported mop     MO_U_Mul2 _w -> unsupported mop+    MO_VS_Quot {} -> unsupported mop+    MO_VS_Rem {} -> unsupported mop+    MO_VU_Quot {} -> unsupported mop+    MO_VU_Rem {} -> unsupported mop+    MO_I64X2_Min -> unsupported mop+    MO_I64X2_Max -> unsupported mop+    MO_W64X2_Min -> unsupported mop+    MO_W64X2_Max -> unsupported mop     -- Memory Ordering     -- The related C functions are:     -- #include <stdatomic.h>
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -47,12 +47,13 @@ import GHC.Types.Unique.FM import GHC.Types.Unique import GHC.Builtin.Uniques+import GHC.Utils.Misc import GHC.Utils.Monad.State.Strict import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Cmm.Dataflow.Label -import Data.List (nub, foldl1', find)+import Data.List (nub, find) import Data.Maybe import Data.IntSet              (IntSet) import qualified Data.IntSet    as IntSet@@ -410,8 +411,7 @@         , sJumpValidAcc = emptyUFM }  intersects :: [Assoc Store]     -> Assoc Store-intersects []           = emptyAssoc-intersects assocs       = foldl1' intersectAssoc assocs+intersects = foldl1WithDefault' emptyAssoc intersectAssoc   -- | See if we have a reg with the same value as this slot in the association table.
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -36,8 +36,9 @@ import GHC.Utils.Monad.State.Strict import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Format+import GHC.Utils.Misc -import Data.List        (nub, minimumBy)+import Data.List        (nub) import Data.Maybe import Control.Monad (join) @@ -168,7 +169,7 @@ chooseSpill info graph  = let  cost    = spillCost_length info graph         node    = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2))-                $ nonDetEltsUFM $ graphMap graph+                $ expectNonEmpty $ nonDetEltsUFM $ graphMap graph                 -- See Note [Unique Determinism and code generation]     in   nodeId node
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -1,6 +1,3 @@--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Carries interesting info for debugging / profiling of the --   graph coloring register allocator. module GHC.CmmToAsm.Reg.Graph.Stats (@@ -219,11 +216,10 @@  pprStatsSpills stats  = let-        finals  = [ s   | s@RegAllocStatsColored{} <- stats]+        finals  = [srms | RegAllocStatsColored{ raSRMs = srms } <- stats]          -- sum up how many stores\/loads\/reg-reg-moves were left in the code-        total   = foldl' addSRM (0, 0, 0)-                $ map raSRMs finals+        total   = foldl' addSRM (0, 0, 0) finals      in  (  text "-- spills-added-total"         $$ text "--    (stores, loads, reg_reg_moves_remaining)"@@ -237,8 +233,7 @@  pprStatsLifetimes stats  = let  info            = foldl' plusSpillCostInfo zeroSpillCostInfo-                                [ raSpillCosts s-                                        | s@RegAllocStatsStart{} <- stats ]+                          [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ]          lifeBins        = binLifetimeCount $ lifeMapFromSpillCostInfo info @@ -287,20 +282,21 @@ pprStatsLifeConflict stats graph  = let  lifeMap = lifeMapFromSpillCostInfo                 $ foldl' plusSpillCostInfo zeroSpillCostInfo-                $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]+                $ [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ] -        scatter = map   (\r ->  let lifetime  = case lookupUFM lifeMap r of-                                                      Just (_, l) -> l-                                                      Nothing     -> 0-                                    Just node = Color.lookupNode graph r-                                in parens $ hcat $ punctuate (text ", ")-                                        [ doubleQuotes $ ppr $ Color.nodeId node-                                        , ppr $ sizeUniqSet (Color.nodeConflicts node)-                                        , ppr $ lifetime ])-                $ map Color.nodeId-                $ nonDetEltsUFM+        scatter =+          [ let lifetime  = case lookupUFM lifeMap r of+                    Just (_, l) -> l+                    Nothing     -> 0+            in parens $ hcat $ punctuate (text ", ")+              [ doubleQuotes $ ppr $ Color.nodeId node+              , ppr $ sizeUniqSet (Color.nodeConflicts node)+              , ppr $ lifetime ]+          | node <- nonDetEltsUFM                 -- See Note [Unique Determinism and code generation]                 $ Color.graphMap graph+          , let r = Color.nodeId node+          ]     in   (  text "-- vreg-conflict-lifetime"         $$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -148,7 +148,10 @@       Separate.RcInteger -> 14       Separate.RcFloat   -> 20       Separate.RcVector  -> 20-    ArchLoongArch64->panic "trivColorable ArchLoongArch64"+    ArchLoongArch64   -> case rc of+      Separate.RcInteger -> 16+      Separate.RcFloat   -> 24+      Separate.RcVector  -> 24     ArchJavaScript-> panic "trivColorable ArchJavaScript"     ArchWasm32    -> panic "trivColorable ArchWasm32"     ArchUnknown   -> panic "trivColorable ArchUnknown"
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -1,6 +1,4 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- ----------------------------------------------------------------------------- -- -- The register allocator@@ -113,6 +111,7 @@ import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 import qualified GHC.CmmToAsm.Reg.Linear.RV64    as RV64+import qualified GHC.CmmToAsm.Reg.Linear.LA64    as LA64 import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Utils@@ -141,7 +140,7 @@  import Data.Containers.ListUtils import Data.Maybe-import Data.List (partition)+import Data.List (sortOn) import Control.Monad  -- -----------------------------------------------------------------------------@@ -178,8 +177,7 @@                  -- make sure the block that was first in the input list                 --      stays at the front of the output-                let !(!(!first':_), !rest')-                                = partition ((== first_id) . blockId) final_blocks+                let !final_blocks' = sortOn ((/= first_id) . blockId) final_blocks                  let max_spill_slots = maxSpillSlots config                     extra_stack@@ -188,7 +186,7 @@                       | otherwise                       = Nothing -                return  ( CmmProc info lbl live (ListGraph (first' : rest'))+                return  ( CmmProc info lbl live (ListGraph final_blocks')                         , extra_stack                         , Just stats) @@ -228,7 +226,7 @@       ArchMipseb     -> panic "linearRegAlloc ArchMipseb"       ArchMipsel     -> panic "linearRegAlloc ArchMipsel"       ArchRISCV64    -> go (frInitFreeRegs platform :: RV64.FreeRegs)-      ArchLoongArch64-> panic "linearRegAlloc ArchLoongArch64"+      ArchLoongArch64 -> go $ (frInitFreeRegs platform :: LA64.FreeRegs)       ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"       ArchWasm32     -> panic "linearRegAlloc ArchWasm32"       ArchUnknown    -> panic "linearRegAlloc ArchUnknown"
compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs view
@@ -118,6 +118,7 @@ getFreeRegs cls (FreeRegs g f) =   case cls of     RcFloatOrVector -> go 32 f 31+    -- x18 is a platform-reserved register for Win/Mac and free for Linux (See Note [Aarch64 Register x18 at Darwin and Windows])     RcInteger       -> go  0 g 18     where         go _   _ i | i < 0 = []
compiler/GHC/CmmToAsm/Reg/Linear/Base.hs view
@@ -207,4 +207,3 @@          } -
compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view
@@ -34,11 +34,13 @@ import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 import qualified GHC.CmmToAsm.Reg.Linear.RV64    as RV64+import qualified GHC.CmmToAsm.Reg.Linear.LA64    as LA64  import qualified GHC.CmmToAsm.PPC.Instr     as PPC.Instr import qualified GHC.CmmToAsm.X86.Instr     as X86.Instr import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr import qualified GHC.CmmToAsm.RV64.Instr    as RV64.Instr+import qualified GHC.CmmToAsm.LA64.Instr    as LA64.Instr  class Show freeRegs => FR freeRegs where     frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs@@ -76,6 +78,12 @@     frInitFreeRegs = RV64.initFreeRegs     frReleaseReg = const RV64.releaseReg +instance FR LA64.FreeRegs where+    frAllocateReg = \_ -> LA64.allocateReg+    frGetFreeRegs = \_ -> LA64.getFreeRegs+    frInitFreeRegs = LA64.initFreeRegs+    frReleaseReg = \_ -> LA64.releaseReg+ allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg] allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs plat rcls fr) allRegClasses   where@@ -98,7 +106,7 @@    ArchMipseb    -> panic "maxSpillSlots ArchMipseb"    ArchMipsel    -> panic "maxSpillSlots ArchMipsel"    ArchRISCV64   -> RV64.Instr.maxSpillSlots config-   ArchLoongArch64->panic "maxSpillSlots ArchLoongArch64"+   ArchLoongArch64  -> LA64.Instr.maxSpillSlots config    ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"    ArchWasm32    -> panic "maxSpillSlots ArchWasm32"    ArchUnknown   -> panic "maxSpillSlots ArchUnknown"
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Handles joining of a jump instruction to its targets.  --      The first time we encounter a jump to a particular basic block, we@@ -25,6 +23,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Label import GHC.Data.Graph.Directed+import GHC.Data.Maybe import GHC.Utils.Panic import GHC.Utils.Monad (concatMapM) import GHC.Types.Unique@@ -90,7 +89,7 @@          -- adjust the current assignment to remove any vregs that are not live         -- on entry to the destination block.-        let Just live_set       = mapLookup dest block_live+        let live_set            = expectJust $ mapLookup dest block_live         let still_live uniq _   = uniq `elemUniqSet_Directly` live_set         let adjusted_assig      = filterUFM_Directly still_live assig 
+ compiler/GHC/CmmToAsm/Reg/Linear/LA64.hs view
@@ -0,0 +1,71 @@+module GHC.CmmToAsm.Reg.Linear.LA64 where++import GHC.Prelude++import Data.Word+import GHC.CmmToAsm.LA64.Regs+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Separate+import GHC.Stack+import GHC.Utils.Outputable+import GHC.Utils.Panic++data FreeRegs = FreeRegs !Word32 !Word32++noFreeRegs :: FreeRegs+noFreeRegs = FreeRegs 0 0++instance Show FreeRegs where+  show (FreeRegs g f) = "FreeRegs 0b" ++ showBits g ++ " 0b" ++ showBits f++-- | Show bits as a `String` of @1@s and @0@s+showBits :: Word32 -> String+showBits w = map (\i -> if testBit w i then '1' else '0') [0 .. 31]++instance Outputable FreeRegs where+  ppr (FreeRegs g f) =+         text "   " <+> foldr (\i x -> pad_int i <+> x) (text "") [0 .. 31]+      $$ text "GPR" <+> foldr (\i x -> show_bit g i <+> x) (text "") [0 .. 31]+      $$ text "FPR" <+> foldr (\i x -> show_bit f i <+> x) (text "") [0 .. 31]+    where+      pad_int i | i < 10 = char ' ' <> int i+      pad_int i = int i+      -- remember bit = 1 means it's available.+      show_bit bits bit | testBit bits bit = text "  "+      show_bit _ _ = text " x"++-- | Set bits of all allocatable registers to 1+initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)++-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1)+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]+getFreeRegs cls (FreeRegs g f)+  | RcInteger <- cls = go 0 g allocatableIntRegs+  | RcFloat   <- cls = go 32 f allocatableDoubleRegs+  | RcVector  <- cls = sorry "Linear.LA64.getFreeRegs: vector registers are not supported"+  where+    go _ _ [] = []+    go off x (i : is)+      | testBit x i = RealRegSingle (off + i) : (go off x $! is)+      | otherwise = go off x $! is+    allocatableIntRegs = [4 .. 11] ++ [12 .. 19]+    allocatableDoubleRegs = [0 .. 7] ++ [8 .. 23]++-- | Set corresponding register bit to 0+allocateReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs+allocateReg (RealRegSingle r) (FreeRegs g f)+  | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32))+  | r < 32 && testBit g r = FreeRegs (clearBit g r) f+  | r > 31 = panic $ "Linear.LA64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f+  | otherwise = pprPanic "Linear.LA64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)++-- | Set corresponding register bit to 1+releaseReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs+releaseReg (RealRegSingle r) (FreeRegs g f)+  | r > 31 && testBit f (r - 32) = pprPanic "Linear.LA64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32))+  | r < 32 && testBit g r = pprPanic "Linear.LA64.releaseReg" (text "can't release non-allocated reg x" <> int r)+  | r > 31 = FreeRegs g (setBit f (r - 32))+  | otherwise = FreeRegs (setBit g r) f
compiler/GHC/CmmToAsm/Reg/Liveness.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE TypeFamilies #-} --{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- ----------------------------------------------------------------------------- -- -- The register liveness determinator@@ -62,7 +59,7 @@ import GHC.Data.Bag import GHC.Utils.Monad.State.Strict -import Data.List (mapAccumL, partition)+import Data.List (mapAccumL, sortOn) import Data.Maybe import Data.IntSet              (IntSet) import GHC.Utils.Misc@@ -530,11 +527,10 @@                 -- make sure the block that was first in the input list                 --      stays at the front of the output. This is the entry point                 --      of the proc, and it needs to come first.-                ((first':_), rest')-                                = partition ((== first_id) . blockId) final_blocks+                final_blocks' = sortOn ((/= first_id) . blockId) final_blocks -           in   CmmProc info label live-                          (ListGraph $ map (stripLiveBlock config) $ first' : rest')+           in   CmmProc info label live $ ListGraph $+                map (stripLiveBlock config) final_blocks'          -- If the proc has blocks but we don't know what the first one was, then we're dead.         stripCmm proc
compiler/GHC/CmmToAsm/Reg/Target.hs view
@@ -38,6 +38,7 @@ import qualified GHC.CmmToAsm.PPC.Regs       as PPC import qualified GHC.CmmToAsm.AArch64.Regs   as AArch64 import qualified GHC.CmmToAsm.RV64.Regs   as RV64+import qualified GHC.CmmToAsm.LA64.Regs      as LA64  targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int targetVirtualRegSqueeze platform@@ -53,7 +54,7 @@       ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"       ArchRISCV64   -> RV64.virtualRegSqueeze-      ArchLoongArch64->panic "targetVirtualRegSqueeze ArchLoongArch64"+      ArchLoongArch64 -> LA64.virtualRegSqueeze       ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"       ArchWasm32    -> panic "targetVirtualRegSqueeze ArchWasm32"       ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown"@@ -73,7 +74,7 @@       ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"       ArchRISCV64   -> RV64.realRegSqueeze-      ArchLoongArch64->panic "targetRealRegSqueeze ArchLoongArch64"+      ArchLoongArch64 -> LA64.realRegSqueeze       ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"       ArchWasm32    -> panic "targetRealRegSqueeze ArchWasm32"       ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown"@@ -92,7 +93,7 @@       ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"       ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"       ArchRISCV64   -> RV64.classOfRealReg-      ArchLoongArch64->panic "targetClassOfRealReg ArchLoongArch64"+      ArchLoongArch64 -> LA64.classOfRealReg       ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"       ArchWasm32    -> panic "targetClassOfRealReg ArchWasm32"       ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown"@@ -111,7 +112,7 @@       ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"       ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"       ArchRISCV64   -> RV64.mkVirtualReg-      ArchLoongArch64->panic "targetMkVirtualReg ArchLoongArch64"+      ArchLoongArch64 -> LA64.mkVirtualReg       ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"       ArchWasm32    -> panic "targetMkVirtualReg ArchWasm32"       ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown"@@ -130,7 +131,7 @@       ArchMipseb    -> panic "targetRegDotColor ArchMipseb"       ArchMipsel    -> panic "targetRegDotColor ArchMipsel"       ArchRISCV64   -> RV64.regDotColor-      ArchLoongArch64->panic "targetRegDotColor ArchLoongArch64"+      ArchLoongArch64 -> LA64.regDotColor       ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"       ArchWasm32    -> panic "targetRegDotColor ArchWasm32"       ArchUnknown   -> panic "targetRegDotColor ArchUnknown"
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -6,5106 +6,6252 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- Generating machine code (instruction selection)------ (c) The University of Glasgow 1996-2004------------------------------------------------------------------------------------- This is a big module, but, if you pay attention to--- (a) the sectioning, and (b) the type signatures, the--- structure should not be too overwhelming.--module GHC.CmmToAsm.X86.CodeGen (-        cmmTopCodeGen,-        generateJumpTableForInstr,-        extractUnwindPoints,-        invertCondBranches,-        InstrBlock-)--where---- NCG stuff:-import GHC.Prelude--import GHC.CmmToAsm.X86.Instr-import GHC.CmmToAsm.X86.Cond-import GHC.CmmToAsm.X86.Regs-import GHC.CmmToAsm.X86.Ppr-import GHC.CmmToAsm.X86.RegInfo--import GHC.Platform.Regs-import GHC.CmmToAsm.CPrim-import GHC.CmmToAsm.Types-import GHC.Cmm.DebugBlock-   ( DebugBlock(..), UnwindPoint(..), UnwindTable-   , UnwindExpr(UwReg), toUnwindExpr-   )-import GHC.CmmToAsm.PIC-import GHC.CmmToAsm.Monad-   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat-   , getDeltaNat, getBlockIdNat, getPicBaseNat-   , Reg64(..), RegCode64(..), getNewReg64, localReg64-   , getPicBaseMaybeNat, getDebugBlock, getFileId-   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform-   , getCfgWeights-   )-import GHC.CmmToAsm.CFG-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Config-import GHC.Platform.Reg-import GHC.Platform---- Our intermediate code:-import GHC.Types.Basic-import GHC.Cmm.BlockId-import GHC.Unit.Types ( primUnitId )-import GHC.Cmm.Utils-import GHC.Cmm.Switch-import GHC.Cmm-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Label-import GHC.Cmm.CLabel-import GHC.Types.Tickish ( GenTickish(..) )-import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )---- The rest:-import GHC.Data.Maybe ( expectJust )-import GHC.Types.ForeignCall ( CCallConv(..) )-import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Monad ( foldMapM )-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Types.Unique.DSM ( getUniqueM )--import qualified Data.Semigroup as S--import Control.Monad-import Control.Monad.Trans.State.Strict-  ( StateT, evalStateT, get, put )-import Control.Monad.Trans.Class (lift)-import Data.Foldable (fold)-import Data.Int-import Data.Maybe-import Data.Word--import qualified Data.Map as Map--is32BitPlatform :: NatM Bool-is32BitPlatform = do-    platform <- getPlatform-    return $ target32Bit platform--sse4_1Enabled :: NatM Bool-sse4_1Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE4)--sse4_2Enabled :: NatM Bool-sse4_2Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE42)--avxEnabled :: NatM Bool-avxEnabled = do-  config <- getConfig-  return (ncgAvxEnabled config)--cmmTopCodeGen-        :: RawCmmDecl-        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]--cmmTopCodeGen (CmmProc info lab live graph) = do-  let blocks = toBlockListEntryFirst graph-  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks-  picBaseMb <- getPicBaseMaybeNat-  platform <- getPlatform-  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)-      tops = proc : concat statics-      os   = platformOS platform--  case picBaseMb of-      Just picBase -> initializePicBase_x86 os picBase tops-      Nothing -> return tops--cmmTopCodeGen (CmmData sec dat) =-  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic--{- Note [Verifying basic blocks]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   We want to guarantee a few things about the results-   of instruction selection.--   Namely that each basic blocks consists of:-    * A (potentially empty) sequence of straight line instructions-  followed by-    * A (potentially empty) sequence of jump like instructions.--    We can verify this by going through the instructions and-    making sure that any non-jumpish instruction can't appear-    after a jumpish instruction.--    There are gotchas however:-    * CALLs are strictly speaking control flow but here we care-      not about them. Hence we treat them as regular instructions.--      It's safe for them to appear inside a basic block-      as (ignoring side effects inside the call) they will result in-      straight line code.--    * NEWBLOCK marks the start of a new basic block so can-      be followed by any instructions.--}---- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.-verifyBasicBlock :: Platform -> [Instr] -> ()-verifyBasicBlock platform instrs-  | debugIsOn     = go False instrs-  | otherwise     = ()-  where-    go _     [] = ()-    go atEnd (i:instr)-        = case i of-            -- Start a new basic block-            NEWBLOCK {} -> go False instr-            -- Calls are not viable block terminators-            CALL {}     | atEnd -> faultyBlockWith i-                        | not atEnd -> go atEnd instr-            -- All instructions ok, check if we reached the end and continue.-            _ | not atEnd -> go (isJumpishInstr i) instr-              -- Only jumps allowed at the end of basic blocks.-              | otherwise -> if isJumpishInstr i-                                then go True instr-                                else faultyBlockWith i-    faultyBlockWith i-        = pprPanic "Non control flow instructions after end of basic block."-                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))--basicBlockCodeGen-        :: CmmBlock-        -> NatM ( [NatBasicBlock Instr]-                , [NatCmmDecl (Alignment, RawCmmStatics) Instr])--basicBlockCodeGen block = do-  let (_, nodes, tail)  = blockSplit block-      id = entryLabel block-      stmts = blockToList nodes-  -- Generate location directive-  dbg <- getDebugBlock (entryLabel block)-  loc_instrs <- case dblSourceTick =<< dbg of-    Just (SourceNote span (LexicalFastString name))-      -> do fileId <- getFileId (srcSpanFile span)-            let line = srcSpanStartLine span; col = srcSpanStartCol span-            return $ unitOL $ LOCATION fileId line col (unpackFS name)-    _ -> return nilOL-  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts-  (!tail_instrs,_) <- stmtToInstrs mid_bid tail-  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs-  platform <- getPlatform-  return $! verifyBasicBlock platform (fromOL instrs)-  instrs' <- fold <$> traverse addSpUnwindings instrs-  -- code generation may introduce new basic block boundaries, which-  -- are indicated by the NEWBLOCK instruction.  We must split up the-  -- instruction stream into basic blocks again.  Also, we extract-  -- LDATAs here too.-  let-        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'--        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)-          = ([], BasicBlock id instrs : blocks, statics)-        mkBlocks (LDATA sec dat) (instrs,blocks,statics)-          = (instrs, blocks, CmmData sec dat:statics)-        mkBlocks instr (instrs,blocks,statics)-          = (instr:instrs, blocks, statics)-  return (BasicBlock id top : other_blocks, statics)---- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes--- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"--- for details.-addSpUnwindings :: Instr -> NatM (OrdList Instr)-addSpUnwindings instr@(DELTA d) = do-    config <- getConfig-    let platform = ncgPlatform config-    if ncgDwarfUnwindings config-        then do lbl <- mkAsmTempLabel <$> getUniqueM-                let unwind = Map.singleton MachSp (Just $ UwReg (GlobalRegUse MachSp (bWord platform)) $ negate d)-                return $ toOL [ instr, UNWIND lbl unwind ]-        else return (unitOL instr)-addSpUnwindings instr = return $ unitOL instr--{- Note [Keeping track of the current block]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When generating instructions for Cmm we sometimes require-the current block for things like retry loops.--We also sometimes change the current block, if a MachOP-results in branching control flow.--Issues arise if we have two statements in the same block,-which both depend on the current block id *and* change the-basic block after them. This happens for atomic primops-in the X86 backend where we want to update the CFG data structure-when introducing new basic blocks.--For example in #17334 we got this Cmm code:--        c3Bf: // global-            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);-            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);-            _s3sT::I64 = _s3sV::I64;-            goto c3B1;--This resulted in two new basic blocks being inserted:--        c3Bf:-                movl $18,%vI_n3Bo-                movq 88(%vI_s3sQ),%rax-                jmp _n3Bp-        n3Bp:-                ...-                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)-                jne _n3Bp-                ...-                jmp _n3Bs-        n3Bs:-                ...-                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)-                jne _n3Bs-                ...-                jmp _c3B1-        ...--Based on the Cmm we called stmtToInstrs we translated both atomic operations under-the assumption they would be placed into their Cmm basic block `c3Bf`.-However for the retry loop we introduce new labels, so this is not the case-for the second statement.-This resulted in a desync between the explicit control flow graph-we construct as a separate data type and the actual control flow graph in the code.--Instead we now return the new basic block if a statement causes a change-in the current block and use the block for all following statements.--For this reason genForeignCall is also split into two parts.  One for calls which-*won't* change the basic blocks in which successive instructions will be-placed (since they only evaluate CmmExpr, which can only contain MachOps, which-cannot introduce basic blocks in their lowerings).  A different one for calls-which *are* known to change the basic block.---}---- See Note [Keeping track of the current block] for why--- we pass the BlockId.-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.-              -> [CmmNode O O] -- ^ Cmm Statement-              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction-stmtsToInstrs bid stmts =-    go bid stmts nilOL-  where-    go bid  []        instrs = return (instrs,bid)-    go bid (s:stmts)  instrs = do-      (instrs',bid') <- stmtToInstrs bid s-      -- If the statement introduced a new block, we use that one-      let !newBid = fromMaybe bid bid'-      go newBid stmts (instrs `appOL` instrs')---- | `bid` refers to the current block and is used to update the CFG---   if new blocks are inserted in the control flow.--- See Note [Keeping track of the current block] for more details.-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.-             -> CmmNode e x-             -> NatM (InstrBlock, Maybe BlockId)-             -- ^ Instructions, and bid of new block if successive-             -- statements are placed in a different basic block.-stmtToInstrs bid stmt = do-  is32Bit <- is32BitPlatform-  platform <- getPlatform-  case stmt of-    CmmUnsafeForeignCall target result_regs args-       -> genForeignCall target result_regs args bid--    _ -> (,Nothing) <$> case stmt of-      CmmComment s   -> return (unitOL (COMMENT s))-      CmmTick {}     -> return nilOL--      CmmUnwind regs -> do-        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable-            to_unwind_entry (reg, expr) = Map.singleton reg (fmap (toUnwindExpr platform) expr)-        case foldMap to_unwind_entry regs of-          tbl | Map.null tbl -> return nilOL-              | otherwise    -> do-                  lbl <- mkAsmTempLabel <$> getUniqueM-                  return $ unitOL $ UNWIND lbl tbl--      CmmAssign reg src-        | isFloatType ty         -> assignReg_FltCode reg src-        | is32Bit && isWord64 ty -> assignReg_I64Code reg src-        | isVecType ty           -> assignReg_VecCode reg src-        | otherwise              -> assignReg_IntCode reg src-          where ty = cmmRegType reg--      CmmStore addr src _alignment-        | isFloatType ty         -> assignMem_FltCode format addr src-        | is32Bit && isWord64 ty -> assignMem_I64Code        addr src-        | isVecType ty           -> assignMem_VecCode format addr src-        | otherwise              -> assignMem_IntCode format addr src-          where ty = cmmExprType platform src-                format = cmmTypeFormat ty--      CmmBranch id          -> return $ genBranch id--      --We try to arrange blocks such that the likely branch is the fallthrough-      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.-      CmmCondBranch arg true false _ -> genCondBranch bid true false arg-      CmmSwitch arg ids -> genSwitch arg ids-      CmmCall { cml_target = arg-              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)-      _ ->-        panic "stmtToInstrs: statement should have been cps'd away"---jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat]-jumpRegs platform gregs =-  [ RegWithFormat (RegReal r) (cmmTypeFormat ty)-  | GlobalRegUse gr ty <- gregs-  , Just r <- [globalRegMaybe platform gr] ]------------------------------------------------------------------------------------- | 'InstrBlock's are the insn sequences generated by the insn selectors.---      They are really trees of insns to facilitate fast appending, where a---      left-to-right traversal yields the insns in the correct order.----type InstrBlock-        = OrdList Instr----- | Condition codes passed up the tree.----data CondCode-        = CondCode Bool Cond InstrBlock----- | Register's passed up the tree.  If the stix code forces the register---      to live in a pre-decided machine register, it comes out as @Fixed@;---      otherwise, it comes out as @Any@, and the parent can decide which---      register to put it in.----data Register-        = Fixed Format Reg InstrBlock-        | Any   Format (Reg -> InstrBlock)---swizzleRegisterRep :: Register -> Format -> Register-swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code-swizzleRegisterRep (Any _ codefn)     format = Any   format codefn--getLocalRegReg :: LocalReg -> Reg-getLocalRegReg (LocalReg u ty)-  = -- by assuming SSE2, Int, Word, Float, Double and vectors all can be register allocated-    RegVirtual (mkVirtualReg u (cmmTypeFormat ty))---- | Grab the Reg for a CmmReg-getRegisterReg :: Platform  -> CmmReg -> Reg--getRegisterReg _   (CmmLocal lreg) = getLocalRegReg lreg--getRegisterReg platform  (CmmGlobal mid)-  = case globalRegMaybe platform $ globalRegUse_reg mid of-        Just reg -> RegReal $ reg-        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)-        -- By this stage, the only MagicIds remaining should be the-        -- ones which map to a real machine register on this-        -- platform.  Hence ...---- | Memory addressing modes passed up the tree.-data Amode-        = Amode AddrMode InstrBlock--{--Now, given a tree (the argument to a CmmLoad) that references memory,-produce a suitable addressing mode.--A Rule of the Game (tm) for Amodes: use of the addr bit must-immediately follow use of the code part, since the code part puts-values in registers which the addr then refers to.  So you can't put-anything in between, lest it overwrite some of those registers.  If-you need to do some other computation between the code part and use of-the addr bit, first store the effective address from the amode in a-temporary, then do the other computation, and then use the temporary:--    code-    LEA amode, tmp-    ... other computation ...-    ... (tmp) ...--}--{--Note [%rip-relative addressing on x86-64]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set,-"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of-specification version 0.99).--In general the small code model would allow us to assume that code is located-between 0 and 2^31 - 1. However, this is not true on Windows which, due to-high-entropy ASLR, may place the executable image anywhere in 64-bit address-space. This is problematic since immediate operands in x86-64 are generally-32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding).-Consequently, to avoid overflowing we use %rip-relative addressing universally.-Since %rip-relative addressing comes essentially for free and makes linking far-easier, we use it even on non-Windows platforms.--See also: the documentation for GCC's `-mcmodel=small` flag.--}----- | Check whether an integer will fit in 32 bits.---      A CmmInt is intended to be truncated to the appropriate---      number of bits, so here we truncate it to Int64.  This is---      important because e.g. -1 as a CmmInt might be either---      -1 or 18446744073709551615.----is32BitInteger :: Integer -> Bool-is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000-  where i64 = fromIntegral i :: Int64----- | Convert a BlockId to some CmmStatic data-jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic-jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))-jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)-    where blockLabel = blockLbl blockid----- -------------------------------------------------------------------------------- General things for putting together code sequences---- Expand CmmRegOff.  ToDo: should we do it this way around, or convert--- CmmExprs into CmmRegOff?-mangleIndexTree :: CmmReg -> Int -> CmmExpr-mangleIndexTree reg off-  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-  where width = typeWidth (cmmRegType reg)---- | The dual to getAnyReg: compute an expression into a register, but---      we don't mind which one it is.-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)-getSomeReg expr = do-  r <- getRegister expr-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed _ reg code ->-        return (reg, code)--assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock-assignMem_I64Code addrTree valueTree = do-  Amode addr addr_code <- getAmode addrTree-  RegCode64 vcode rhi rlo <- iselExpr64 valueTree-  let-        -- Little-endian store-        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)-        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))-  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)---assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_I64Code (CmmLocal dst) valueTree = do-   RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree-   let-         Reg64 r_dst_hi r_dst_lo = localReg64 dst-         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)-         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)-   return (-        vcode `snocOL` mov_lo `snocOL` mov_hi-     )--assignReg_I64Code _ _-   = panic "assignReg_I64Code(i386): invalid lvalue"--iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)-iselExpr64 (CmmLit (CmmInt i _)) = do-  Reg64 rhi rlo <- getNewReg64-  let-        r = fromIntegral (fromIntegral i :: Word32)-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)-        code = toOL [-                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),-                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)-                ]-  return (RegCode64 code rhi rlo)--iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do-   Amode addr addr_code <- getAmode addrTree-   Reg64 rhi rlo <- getNewReg64-   let-        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)-        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)-   return (-            RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo-     )--iselExpr64 (CmmReg (CmmLocal local_reg)) = do-  let Reg64 hi lo = localReg64 local_reg-  return (RegCode64 nilOL hi lo)--iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   Reg64 rhi rlo <- getNewReg64-   let-        r = fromIntegral (fromIntegral i :: Word32)-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)-        code =  code1 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]-   return (RegCode64 code rhi rlo)--iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2-   Reg64 rhi rlo <- getNewReg64-   let-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       ADD II32 (OpReg r2lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       ADC II32 (OpReg r2hi) (OpReg rhi) ]-   return (RegCode64 code rhi rlo)--iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2-   Reg64 rhi rlo <- getNewReg64-   let-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       SUB II32 (OpReg r2lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       SBB II32 (OpReg r2hi) (OpReg rhi) ]-   return (RegCode64 code rhi rlo)--iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do-     code <- getAnyReg expr-     Reg64 r_dst_hi r_dst_lo <- getNewReg64-     return $ RegCode64 (code r_dst_lo `snocOL`-                          XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi))-                          r_dst_hi-                          r_dst_lo--iselExpr64 (CmmMachOp (MO_UU_Conv W16 W64) [expr]) = do-     (rsrc, code) <- getByteReg expr-     Reg64 r_dst_hi r_dst_lo <- getNewReg64-     return $ RegCode64 (code `appOL` toOL [-                          MOVZxL II16 (OpReg rsrc) (OpReg r_dst_lo),-                          XOR    II32 (OpReg r_dst_hi) (OpReg r_dst_hi)-                          ])-                          r_dst_hi-                          r_dst_lo--iselExpr64 (CmmMachOp (MO_UU_Conv W8 W64) [expr]) = do-     (rsrc, code) <- getByteReg expr-     Reg64 r_dst_hi r_dst_lo <- getNewReg64-     return $ RegCode64 (code `appOL` toOL [-                          MOVZxL II8 (OpReg rsrc) (OpReg r_dst_lo),-                          XOR    II32 (OpReg r_dst_hi) (OpReg r_dst_hi)-                          ])-                          r_dst_hi-                          r_dst_lo--iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do-     code <- getAnyReg expr-     Reg64 r_dst_hi r_dst_lo <- getNewReg64-     return $ RegCode64 (code r_dst_lo `snocOL`-                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`-                          CLTD II32 `snocOL`-                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`-                          MOV II32 (OpReg edx) (OpReg r_dst_hi))-                          r_dst_hi-                          r_dst_lo--iselExpr64 (CmmMachOp (MO_SS_Conv W16 W64) [expr]) = do-     (r, code) <- getByteReg expr-     Reg64 r_dst_hi r_dst_lo <- getNewReg64-     return $ RegCode64 (code `appOL` toOL [-                          MOVSxL II16 (OpReg r) (OpReg eax),-                          CLTD II32,-                          MOV II32 (OpReg eax) (OpReg r_dst_lo),-                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])-                          r_dst_hi-                          r_dst_lo--iselExpr64 (CmmMachOp (MO_SS_Conv W8 W64) [expr]) = do-     (r, code) <- getByteReg expr-     Reg64 r_dst_hi r_dst_lo <- getNewReg64-     return $ RegCode64 (code `appOL` toOL [-                          MOVSxL II8 (OpReg r) (OpReg eax),-                          CLTD II32,-                          MOV II32 (OpReg eax) (OpReg r_dst_lo),-                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])-                          r_dst_hi-                          r_dst_lo--iselExpr64 (CmmMachOp (MO_S_Neg _) [expr]) = do-   RegCode64 code rhi rlo <- iselExpr64 expr-   Reg64 rohi rolo <- getNewReg64-   let-        ocode = code `appOL`-                toOL [ MOV II32 (OpReg rlo) (OpReg rolo),-                       XOR II32 (OpReg rohi) (OpReg rohi),-                       NEGI II32 (OpReg rolo),-                       SBB II32 (OpReg rhi) (OpReg rohi) ]-   return (RegCode64 ocode rohi rolo)---- To multiply two 64-bit numbers we use the following decomposition (in C notation):------     ((r1hi << 32) + r1lo) * ((r2hi << 32) + r2lo)---      = ((r2lo * r1hi) << 32)---      + ((r1lo * r2hi) << 32)---      + r1lo * r2lo------ Note that @(r1hi * r2hi) << 64@ can be dropped because it overflows completely.--iselExpr64 (CmmMachOp (MO_Mul _) [e1,e2]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2-   Reg64 rhi rlo <- getNewReg64-   tmp <- getNewRegNat II32-   let-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV  II32 (OpReg r1lo) (OpReg eax),-                       MOV  II32 (OpReg r2lo) (OpReg tmp),-                       MOV  II32 (OpReg r1hi) (OpReg rhi),-                       IMUL II32 (OpReg tmp) (OpReg rhi),-                       MOV  II32 (OpReg r2hi) (OpReg rlo),-                       IMUL II32 (OpReg eax) (OpReg rlo),-                       ADD  II32 (OpReg rlo) (OpReg rhi),-                       MUL2 II32 (OpReg tmp),-                       ADD  II32 (OpReg edx) (OpReg rhi),-                       MOV  II32 (OpReg eax) (OpReg rlo)-                     ]-   return (RegCode64 code rhi rlo)--iselExpr64 (CmmMachOp (MO_S_MulMayOflo W64) _) = do-   -- Performance sensitive users won't use 32 bit so let's keep it simple:-   -- We always return a (usually false) positive.-   Reg64 rhi rlo <- getNewReg64-   let code = toOL   [-                       MOV II32 (OpImm (ImmInt 1)) (OpReg rhi),-                       MOV II32 (OpImm (ImmInt 1)) (OpReg rlo)-                     ]-   return (RegCode64 code rhi rlo)----- To shift a 64-bit number to the left we use the SHLD and SHL instructions.--- We use SHLD to shift the bits in @rhi@ to the left while copying--- high bits from @rlo@ to fill the new space in the low bits of @rhi@.--- That leaves @rlo@ unchanged, so we use SHL to shift the bits of @rlo@ left.--- However, both these instructions only use the lowest 5 bits from %cl to do--- their shifting. So if the sixth bit (0x32) is set then we additionally move--- the contents of @rlo@ to @rhi@ and clear @rlo@.--iselExpr64 (CmmMachOp (MO_Shl _) [e1,e2]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   code2 <- getAnyReg e2-   Reg64 rhi rlo <- getNewReg64-   lbl1 <- newBlockId-   lbl2 <- newBlockId-   let-        code =  code1 `appOL`-                code2 ecx `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       SHLD II32 (OpReg ecx) (OpReg rlo) (OpReg rhi),-                       SHL II32 (OpReg ecx) (OpReg rlo),-                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),-                       JXX EQQ lbl2,-                       JXX ALWAYS lbl1,-                       NEWBLOCK lbl1,-                       MOV II32 (OpReg rlo) (OpReg rhi),-                       XOR II32 (OpReg rlo) (OpReg rlo),-                       JXX ALWAYS lbl2,-                       NEWBLOCK lbl2-                     ]-   return (RegCode64 code rhi rlo)---- Similar to above, however now we're shifting to the right--- and we're doing a signed shift which means that @rhi@ needs--- to be set to either 0 if @rhi@ is positive or 0xffffffff otherwise,--- and if the sixth bit of %cl is set (so the shift amount is more than 32).--- To accomplish that we shift @rhi@ by 31.--iselExpr64 (CmmMachOp (MO_S_Shr _) [e1,e2]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   (r2, code2) <- getSomeReg e2-   Reg64 rhi rlo <- getNewReg64-   lbl1 <- newBlockId-   lbl2 <- newBlockId-   let-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       MOV II32 (OpReg r2) (OpReg ecx),-                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),-                       SAR II32 (OpReg ecx) (OpReg rhi),-                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),-                       JXX EQQ lbl2,-                       JXX ALWAYS lbl1,-                       NEWBLOCK lbl1,-                       MOV II32 (OpReg rhi) (OpReg rlo),-                       SAR II32 (OpImm (ImmInt 31)) (OpReg rhi),-                       JXX ALWAYS lbl2,-                       NEWBLOCK lbl2-                     ]-   return (RegCode64 code rhi rlo)---- Similar to the above.--iselExpr64 (CmmMachOp (MO_U_Shr _) [e1,e2]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   (r2, code2) <- getSomeReg e2-   Reg64 rhi rlo <- getNewReg64-   lbl1 <- newBlockId-   lbl2 <- newBlockId-   let-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       MOV II32 (OpReg r2) (OpReg ecx),-                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),-                       SHR II32 (OpReg ecx) (OpReg rhi),-                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),-                       JXX EQQ lbl2,-                       JXX ALWAYS lbl1,-                       NEWBLOCK lbl1,-                       MOV II32 (OpReg rhi) (OpReg rlo),-                       XOR II32 (OpReg rhi) (OpReg rhi),-                       JXX ALWAYS lbl2,-                       NEWBLOCK lbl2-                     ]-   return (RegCode64 code rhi rlo)--iselExpr64 (CmmMachOp (MO_And _) [e1,e2]) = iselExpr64ParallelBin AND e1 e2-iselExpr64 (CmmMachOp (MO_Or  _) [e1,e2]) = iselExpr64ParallelBin OR  e1 e2-iselExpr64 (CmmMachOp (MO_Xor _) [e1,e2]) = iselExpr64ParallelBin XOR e1 e2--iselExpr64 (CmmMachOp (MO_Not _) [e1]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   Reg64 rhi rlo <- getNewReg64-   let-        code =  code1 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       NOT II32 (OpReg rlo),-                       NOT II32 (OpReg rhi)-                     ]-   return (RegCode64 code rhi rlo)--iselExpr64 (CmmRegOff r i) = iselExpr64 (mangleIndexTree r i)--iselExpr64 expr-   = do-      platform <- getPlatform-      pprPanic "iselExpr64(i386)" (pdoc platform expr $+$ text (show expr))--iselExpr64ParallelBin :: (Format -> Operand -> Operand -> Instr)-                      -> CmmExpr -> CmmExpr -> NatM (RegCode64 (OrdList Instr))-iselExpr64ParallelBin op e1 e2 = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2-   Reg64 rhi rlo <- getNewReg64-   let-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       op  II32 (OpReg r2lo) (OpReg rlo),-                       op  II32 (OpReg r2hi) (OpReg rhi)-                     ]-   return (RegCode64 code rhi rlo)-------------------------------------------------------------------------------------- This is a helper data type which helps reduce the code duplication for--- the code generation of arithmetic operations. This is not specifically--- targetted for any particular type like Int8, Int32 etc-data VectorArithInstns = VA_Add | VA_Sub | VA_Mul | VA_Div | VA_Min | VA_Max--getRegister :: HasDebugCallStack => CmmExpr -> NatM Register-getRegister e = do platform <- getPlatform-                   is32Bit <- is32BitPlatform-                   getRegister' platform is32Bit e--getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register--getRegister' platform is32Bit (CmmReg reg)-  = case reg of-        CmmGlobal (GlobalRegUse PicBaseReg _)-         | is32Bit ->-            -- on x86_64, we have %rip for PicBaseReg, but it's not-            -- a full-featured register, it can only be used for-            -- rip-relative addressing.-            do reg' <- getPicBaseNat (archWordFormat is32Bit)-               return (Fixed (archWordFormat is32Bit) reg' nilOL)-        _ ->-          let ty = cmmRegType reg-              reg_fmt = cmmTypeFormat ty-          in return $ Fixed reg_fmt (getRegisterReg platform reg) nilOL--getRegister' platform is32Bit (CmmRegOff r n)-  = getRegister' platform is32Bit $ mangleIndexTree r n--getRegister' platform is32Bit (CmmMachOp (MO_RelaxedRead w) [e])-  = getRegister' platform is32Bit (CmmLoad e (cmmBits w) NaturallyAligned)--getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])-  = addAlignmentCheck align <$> getRegister' platform is32Bit e---- for 32-bit architectures, support some 64 -> 32 bit conversions:--- TO_W_(x), TO_W_(x >> 32)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do-  RegCode64 code rhi _rlo <- iselExpr64 x-  return $ Fixed II32 rhi code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do-  RegCode64 code rhi _rlo <- iselExpr64 x-  return $ Fixed II32 rhi code--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])- | is32Bit = do-  RegCode64 code _rhi rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])- | is32Bit = do-  RegCode64 code _rhi rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W8) [x])- | is32Bit = do-  RegCode64 code _rhi rlo <- iselExpr64 x-  ro <- getNewRegNat II8-  return $ Fixed II8 ro (code `appOL` toOL [ MOVZxL II8 (OpReg rlo) (OpReg ro) ])--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W16) [x])- | is32Bit = do-  RegCode64 code _rhi rlo <- iselExpr64 x-  ro <- getNewRegNat II16-  return $ Fixed II16 ro (code `appOL` toOL [ MOVZxL II16 (OpReg rlo) (OpReg ro) ])---- catch simple cases of zero- or sign-extended load-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVZxL II8) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVSxL II8) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVZxL II16) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVSxL II16) addr-  return (Any II32 code)---- catch simple cases of zero- or sign-extended load-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVZxL II8) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II8) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVZxL II16) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II16) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II32) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)),-                                     CmmLit displacement])- | not is32Bit =-      return $ Any II64 (\dst -> unitOL $-        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))--getRegister' _ _ (CmmMachOp mop []) =-  pprPanic "getRegister(x86): nullary MachOp" (text $ show mop)--getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps-    avx    <- avxEnabled-    case mop of-      MO_F_Neg w  -> sse2NegCode w x---      MO_S_Neg w -> triv_ucode NEGI (intFormat w)-      MO_Not w   -> triv_ucode NOT  (intFormat w)--      -- Nop conversions-      MO_UU_Conv W32 W8  -> toI8Reg  W32 x-      MO_SS_Conv W32 W8  -> toI8Reg  W32 x-      MO_XX_Conv W32 W8  -> toI8Reg  W32 x-      MO_UU_Conv W16 W8  -> toI8Reg  W16 x-      MO_SS_Conv W16 W8  -> toI8Reg  W16 x-      MO_XX_Conv W16 W8  -> toI8Reg  W16 x-      MO_UU_Conv W32 W16 -> toI16Reg W32 x-      MO_SS_Conv W32 W16 -> toI16Reg W32 x-      MO_XX_Conv W32 W16 -> toI16Reg W32 x--      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x-      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x-      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x--      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x-      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x-      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x--      MO_FW_Bitcast W32 -> bitcast FF32 II32 x-      MO_WF_Bitcast W32 -> bitcast II32 FF32 x-      MO_FW_Bitcast W64 -> bitcast FF64 II64 x-      MO_WF_Bitcast W64 -> bitcast II64 FF64 x-      MO_WF_Bitcast {}  -> incorrectOperands-      MO_FW_Bitcast {}  -> incorrectOperands--      -- widenings-      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x-      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x-      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x--      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x-      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x-      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x--      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we-      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register-      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.-      MO_XX_Conv W8  W32-          | is32Bit   -> integerExtend W8 W32 MOVZxL x-          | otherwise -> integerExtend W8 W32 MOV x-      MO_XX_Conv W8  W16-          | is32Bit   -> integerExtend W8 W16 MOVZxL x-          | otherwise -> integerExtend W8 W16 MOV x-      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x--      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x-      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x-      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x-      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x-      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x-      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x-      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.-      -- However, we don't want the register allocator to throw it-      -- away as an unnecessary reg-to-reg move, so we keep it in-      -- the form of a movzl and print it as a movl later.-      -- This doesn't apply to MO_XX_Conv since in this case we don't care about-      -- the upper bits. So we can just use MOV.-      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x-      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x-      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x--      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x-      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x--      MO_FF_Conv from to -> invalidConversion from to-      MO_UU_Conv from to -> invalidConversion from to-      MO_SS_Conv from to -> invalidConversion from to-      MO_XX_Conv from to -> invalidConversion from to--      MO_FS_Truncate from to -> coerceFP2Int from to x-      MO_SF_Round    from to -> coerceInt2FP from to x--      MO_VF_Neg l w  | avx       -> vector_float_negate_avx l w x-                     | otherwise -> vector_float_negate_sse l w x-      -- SIMD NCG TODO: add integer negation-      MO_VS_Neg {} -> needLlvm mop--      MO_VF_Broadcast l w-        | avx-        -> vector_float_broadcast_avx l w x-        | otherwise-        -> vector_float_broadcast_sse l w x-      MO_V_Broadcast l w-        -> vector_int_broadcast l w x--      -- Binary MachOps-      MO_Add {}    -> incorrectOperands-      MO_Sub {}    -> incorrectOperands-      MO_Eq {}     -> incorrectOperands-      MO_Ne {}     -> incorrectOperands-      MO_Mul {}    -> incorrectOperands-      MO_S_MulMayOflo {} -> incorrectOperands-      MO_S_Quot {} -> incorrectOperands-      MO_S_Rem {}  -> incorrectOperands-      MO_U_Quot {} -> incorrectOperands-      MO_U_Rem {}  -> incorrectOperands-      MO_S_Ge {}   -> incorrectOperands-      MO_S_Le {}   -> incorrectOperands-      MO_S_Gt {}   -> incorrectOperands-      MO_S_Lt {}   -> incorrectOperands-      MO_U_Ge {}   -> incorrectOperands-      MO_U_Le {}   -> incorrectOperands-      MO_U_Gt {}   -> incorrectOperands-      MO_U_Lt {}   -> incorrectOperands-      MO_F_Add {}  -> incorrectOperands-      MO_F_Sub {}  -> incorrectOperands-      MO_F_Mul {}  -> incorrectOperands-      MO_F_Quot {} -> incorrectOperands-      MO_F_Eq {}   -> incorrectOperands-      MO_F_Ne {}   -> incorrectOperands-      MO_F_Ge {}   -> incorrectOperands-      MO_F_Le {}   -> incorrectOperands-      MO_F_Gt {}   -> incorrectOperands-      MO_F_Lt {}   -> incorrectOperands-      MO_F_Min {}  -> incorrectOperands-      MO_F_Max {}  -> incorrectOperands-      MO_And {}    -> incorrectOperands-      MO_Or {}     -> incorrectOperands-      MO_Xor {}    -> incorrectOperands-      MO_Shl {}    -> incorrectOperands-      MO_U_Shr {}  -> incorrectOperands-      MO_S_Shr {}  -> incorrectOperands--      MO_V_Extract {}     -> incorrectOperands-      MO_V_Add {}         -> incorrectOperands-      MO_V_Sub {}         -> incorrectOperands-      MO_V_Mul {}         -> incorrectOperands-      MO_VS_Quot {}       -> incorrectOperands-      MO_VS_Rem {}        -> incorrectOperands-      MO_VU_Quot {}       -> incorrectOperands-      MO_VU_Rem {}        -> incorrectOperands-      MO_V_Shuffle {}     -> incorrectOperands-      MO_VF_Shuffle {}    -> incorrectOperands-      MO_VU_Min {}  -> incorrectOperands-      MO_VU_Max {}  -> incorrectOperands-      MO_VS_Min {}  -> incorrectOperands-      MO_VS_Max {}  -> incorrectOperands-      MO_VF_Min {}  -> incorrectOperands-      MO_VF_Max {}  -> incorrectOperands--      MO_VF_Extract {}    -> incorrectOperands-      MO_VF_Add {}        -> incorrectOperands-      MO_VF_Sub {}        -> incorrectOperands-      MO_VF_Mul {}        -> incorrectOperands-      MO_VF_Quot {}       -> incorrectOperands--      -- Ternary MachOps-      MO_FMA {}           -> incorrectOperands-      MO_VF_Insert {}     -> incorrectOperands-      MO_V_Insert {}      -> incorrectOperands--      --_other -> pprPanic "getRegister" (pprMachOp mop)-   where-        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register-        triv_ucode instr format = trivialUCode format (instr format) x--        -- signed or unsigned extension.-        integerExtend :: Width -> Width-                      -> (Format -> Operand -> Operand -> Instr)-                      -> CmmExpr -> NatM Register-        integerExtend from to instr expr = do-            (reg,e_code) <- if from == W8 then getByteReg expr-                                          else getSomeReg expr-            let-                code dst =-                  e_code `snocOL`-                  instr (intFormat from) (OpReg reg) (OpReg dst)-            return (Any (intFormat to) code)--        bitcast :: Format -> Format -> CmmExpr -> NatM Register-        bitcast fmt rfmt expr =-          do (src, e_code) <- getSomeReg expr-             let code = \dst -> e_code `snocOL` (MOVD fmt rfmt (OpReg src) (OpReg dst))-             return (Any rfmt code)--        toI8Reg :: Width -> CmmExpr -> NatM Register-        toI8Reg new_rep expr-            = do codefn <- getAnyReg expr-                 return (Any (intFormat new_rep) codefn)-                -- HACK: use getAnyReg to get a byte-addressable register.-                -- If the source was a Fixed register, this will add the-                -- mov instruction to put it into the desired destination.-                -- We're assuming that the destination won't be a fixed-                -- non-byte-addressable register; it won't be, because all-                -- fixed registers are word-sized.--        toI16Reg = toI8Reg -- for now--        conversionNop :: Format -> CmmExpr -> NatM Register-        conversionNop new_format expr-            = do e_code <- getRegister' platform is32Bit expr-                 return (swizzleRegisterRep e_code new_format)--        vector_float_negate_avx :: Length -> Width -> CmmExpr -> NatM Register-        vector_float_negate_avx l w expr = do-          let fmt :: Format-              mask :: CmmLit-              (fmt, mask) = case w of-                       W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- TODO: these should be negative 0 floating point literals,-                       W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- but we don't currently have those in Cmm.-                       _ -> panic "AVX floating-point negation: elements must be FF32 or FF64"-          (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask)-          (reg, exp) <- getSomeReg expr-          let code dst = maskCode `appOL`-                         exp `snocOL`-                         (VMOVU fmt (OpReg reg) (OpReg dst)) `snocOL`-                         (VXOR fmt (OpReg maskReg) dst dst)-          return (Any fmt code)--        vector_float_negate_sse :: Length -> Width -> CmmExpr -> NatM Register-        vector_float_negate_sse l w expr = do-          let fmt :: Format-              mask :: CmmLit-              (fmt, mask) = case w of-                       W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- Same comment as for vector_float_negate_avx,-                       W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- these should be -0.0 CmmFloat values.-                       _ -> panic "SSE floating-point negation: elements must be FF32 or FF64"-          (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask)-          (reg, exp) <- getSomeReg expr-          let code dst = maskCode `appOL`-                         exp `snocOL`-                         (MOVU fmt (OpReg reg) (OpReg dst)) `snocOL`-                         (XOR  fmt (OpReg maskReg) (OpReg dst))-          return (Any fmt code)--        -------------------------        -- TODO: we could use VBROADCASTSS/SD when AVX2 is available.-        vector_float_broadcast_avx :: Length-                                   -> Width-                                   -> CmmExpr-                                   -> NatM Register-        vector_float_broadcast_avx len w expr = do-          (dst, exp) <- getSomeReg expr-          let fmt = VecFormat len (floatScalarFormat w)-              code = VSHUF fmt (ImmInt 0) (OpReg dst) dst dst-          return $ Fixed fmt dst (exp `snocOL` code)--        vector_float_broadcast_sse :: Length-                                   -> Width-                                   -> CmmExpr-                                   -> NatM Register-        vector_float_broadcast_sse len w expr = do-          (dst, exp) <- getSomeReg expr-          let fmt = VecFormat len (floatScalarFormat w)-              code = SHUF fmt (ImmInt 0) (OpReg dst) dst-          return $ Fixed fmt dst (exp `snocOL` code)--        vector_int_broadcast :: Length-                             -> Width-                             -> CmmExpr-                             -> NatM Register-        vector_int_broadcast len W64 expr = do-          (reg, exp) <- getNonClobberedReg expr-          let fmt = VecFormat len FmtInt64-          return $ Any fmt (\dst -> exp `snocOL`-                                    (MOVD II64 fmt (OpReg reg) (OpReg dst)) `snocOL`-                                    (PUNPCKLQDQ fmt (OpReg dst) dst)-                                    )-        vector_int_broadcast len W32 expr = do-          (reg, exp) <- getNonClobberedReg expr-          let fmt = VecFormat len FmtInt32-          return $ Any fmt (\dst -> exp `snocOL`-                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`-                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)-                                    )-        vector_int_broadcast _ _ _ =-          sorry "Unsupported Integer vector broadcast operation; please use -fllvm."---getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps-  avx <- avxEnabled-  case mop of-      MO_F_Eq _ -> condFltReg is32Bit EQQ x y-      MO_F_Ne _ -> condFltReg is32Bit NE  x y-      MO_F_Gt _ -> condFltReg is32Bit GTT x y-      MO_F_Ge _ -> condFltReg is32Bit GE  x y-      -- Invert comparison condition and swap operands-      -- See Note [SSE Parity Checks]-      MO_F_Lt _ -> condFltReg is32Bit GTT  y x-      MO_F_Le _ -> condFltReg is32Bit GE   y x--      MO_Eq _   -> condIntReg EQQ x y-      MO_Ne _   -> condIntReg NE  x y--      MO_S_Gt _ -> condIntReg GTT x y-      MO_S_Ge _ -> condIntReg GE  x y-      MO_S_Lt _ -> condIntReg LTT x y-      MO_S_Le _ -> condIntReg LE  x y--      MO_U_Gt _ -> condIntReg GU  x y-      MO_U_Ge _ -> condIntReg GEU x y-      MO_U_Lt _ -> condIntReg LU  x y-      MO_U_Le _ -> condIntReg LEU x y--      MO_F_Add  w -> trivialFCode_sse2 w ADD  x y-      MO_F_Sub  w -> trivialFCode_sse2 w SUB  x y-      MO_F_Quot w -> trivialFCode_sse2 w FDIV x y-      MO_F_Mul  w -> trivialFCode_sse2 w MUL  x y-      MO_F_Min  w -> trivialFCode_sse2 w (MINMAX Min FloatMinMax) x y-      MO_F_Max  w -> trivialFCode_sse2 w (MINMAX Max FloatMinMax) x y--      MO_Add rep -> add_code rep x y-      MO_Sub rep -> sub_code rep x y--      MO_S_Quot rep -> div_code rep True  True  x y-      MO_S_Rem  rep -> div_code rep True  False x y-      MO_U_Quot rep -> div_code rep False True  x y-      MO_U_Rem  rep -> div_code rep False False x y--      MO_S_MulMayOflo rep -> imulMayOflo rep x y--      MO_Mul W8  -> imulW8 x y-      MO_Mul rep -> triv_op rep IMUL-      MO_And rep -> triv_op rep AND-      MO_Or  rep -> triv_op rep OR-      MO_Xor rep -> triv_op rep XOR--        {- Shift ops on x86s have constraints on their source, it-           either has to be Imm, CL or 1-            => trivialCode is not restrictive enough (sigh.)-        -}-      MO_Shl rep   -> shift_code rep SHL x y {-False-}-      MO_U_Shr rep -> shift_code rep SHR x y {-False-}-      MO_S_Shr rep -> shift_code rep SAR x y {-False-}--      MO_VF_Shuffle l w is-        | l * widthInBits w == 128-        -> if-            | avx-            -> vector_shuffle_float l w x y is-            | otherwise-            -> sorry "Please enable the -mavx flag"-        | otherwise-        -> sorry "Please use -fllvm for wide shuffle instructions"--      MO_VF_Extract l W32   | avx       -> vector_float_extract l W32 x y-                            | otherwise -> vector_float_extract_sse l W32 x y-      MO_VF_Extract l W64               -> vector_float_extract l W64 x y-      MO_VF_Extract {} -> incorrectOperands--      MO_V_Extract l W64                -> vector_int_extract_sse l W64 x y-      -- SIMD NCG TODO: W32, W16, W8-      MO_V_Extract {} -> needLlvm mop--      MO_VF_Add l w         | avx       -> vector_float_op_avx VA_Add l w x y-                            | otherwise -> vector_float_op_sse VA_Add l w x y--      MO_VF_Sub l w         | avx       -> vector_float_op_avx VA_Sub l w x y-                            | otherwise -> vector_float_op_sse VA_Sub l w x y--      MO_VF_Mul l w         | avx       -> vector_float_op_avx VA_Mul l w x y-                            | otherwise -> vector_float_op_sse VA_Mul l w x y--      MO_VF_Quot l w        | avx       -> vector_float_op_avx VA_Div l w x y-                            | otherwise -> vector_float_op_sse VA_Div l w x y--      MO_VF_Min l w         | avx       -> vector_float_op_avx VA_Min l w x y-                            | otherwise -> vector_float_op_sse VA_Min l w x y--      MO_VF_Max l w         | avx       -> vector_float_op_avx VA_Max l w x y-                            | otherwise -> vector_float_op_sse VA_Max l w x y--      -- SIMD NCG TODO: integer vector operations-      MO_V_Shuffle {} -> needLlvm mop-      MO_V_Add {} -> needLlvm mop-      MO_V_Sub {} -> needLlvm mop-      MO_V_Mul {} -> needLlvm mop-      MO_VS_Quot {} -> needLlvm mop-      MO_VS_Rem {} -> needLlvm mop-      MO_VU_Quot {} -> needLlvm mop-      MO_VU_Rem {} -> needLlvm mop--      MO_VU_Min {} -> needLlvm mop-      MO_VU_Max {} -> needLlvm mop-      MO_VS_Min {} -> needLlvm mop-      MO_VS_Max {} -> needLlvm mop--      -- Unary MachOps-      MO_S_Neg {} -> incorrectOperands-      MO_F_Neg {} -> incorrectOperands-      MO_Not {} -> incorrectOperands-      MO_SF_Round {} -> incorrectOperands-      MO_FS_Truncate {} -> incorrectOperands-      MO_SS_Conv {} -> incorrectOperands-      MO_XX_Conv {} -> incorrectOperands-      MO_FF_Conv {} -> incorrectOperands-      MO_UU_Conv {} -> incorrectOperands-      MO_WF_Bitcast {} -> incorrectOperands-      MO_FW_Bitcast  {} -> incorrectOperands-      MO_RelaxedRead {} -> incorrectOperands-      MO_AlignmentCheck {} -> incorrectOperands-      MO_VS_Neg {} -> incorrectOperands-      MO_VF_Neg {} -> incorrectOperands-      MO_V_Broadcast {} -> incorrectOperands-      MO_VF_Broadcast {} -> incorrectOperands--      -- Ternary MachOps-      MO_FMA {} -> incorrectOperands-      MO_V_Insert {} -> incorrectOperands-      MO_VF_Insert {} -> incorrectOperands--  where-    ---------------------    triv_op width instr = trivialCode width op (Just op) x y-                        where op   = instr (intFormat width)--    -- Special case for IMUL for bytes, since the result of IMULB will be in-    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider-    -- values.-    imulW8 :: CmmExpr -> CmmExpr -> NatM Register-    imulW8 arg_a arg_b = do-        (a_reg, a_code) <- getNonClobberedReg arg_a-        b_code <- getAnyReg arg_b--        let code = a_code `appOL` b_code eax `appOL`-                   toOL [ IMUL2 format (OpReg a_reg) ]-            format = intFormat W8--        return (Fixed format eax code)--    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register-    imulMayOflo W8 a b = do-         -- The general case (W16, W32, W64) doesn't work for W8 as its-         -- multiplication doesn't use two registers.-         ---         -- The plan is:-         -- 1. truncate and sign-extend a and b to 8bit width-         -- 2. multiply a' = a * b in 32bit width-         -- 3. copy and sign-extend 8bit from a' to c-         -- 4. compare a' and c: they are equal if there was no overflow-         (a_reg, a_code) <- getNonClobberedReg a-         (b_reg, b_code) <- getNonClobberedReg b-         let-             code = a_code `appOL` b_code `appOL`-                        toOL [-                           MOVSxL II8 (OpReg a_reg) (OpReg a_reg),-                           MOVSxL II8 (OpReg b_reg) (OpReg b_reg),-                           IMUL II32 (OpReg b_reg) (OpReg a_reg),-                           MOVSxL II8 (OpReg a_reg) (OpReg eax),-                           CMP II16 (OpReg a_reg) (OpReg eax),-                           SETCC NE (OpReg eax)-                        ]-         return (Fixed II8 eax code)-    imulMayOflo rep a b = do-         (a_reg, a_code) <- getNonClobberedReg a-         b_code <- getAnyReg b-         let-             shift_amt  = case rep of-                           W16 -> 15-                           W32 -> 31-                           W64 -> 63-                           w -> panic ("shift_amt: " ++ show w)--             format = intFormat rep-             code = a_code `appOL` b_code eax `appOL`-                        toOL [-                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax-                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),-                                -- sign extend lower part-                           SUB format (OpReg edx) (OpReg eax)-                                -- compare against upper-                           -- eax==0 if high part == sign extended low part-                        ]-         return (Fixed format eax code)--    ---------------------    shift_code :: Width-               -> (Format -> Operand -> Operand -> Instr)-               -> CmmExpr-               -> CmmExpr-               -> NatM Register--    {- Case1: shift length as immediate -}-    shift_code width instr x (CmmLit lit)-      -- Handle the case of a shift larger than the width of the shifted value.-      -- This is necessary since x86 applies a mask of 0x1f to the shift-      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by-      -- `47 & 0x1f == 15`. See #20626.-      | CmmInt n _ <- lit-      , n >= fromIntegral (widthInBits width)-      = getRegister $ CmmLit $ CmmInt 0 width--      | otherwise = do-          x_code <- getAnyReg x-          let-               format = intFormat width-               code dst-                  = x_code dst `snocOL`-                    instr format (OpImm (litToImm lit)) (OpReg dst)-          return (Any format code)--    {- Case2: shift length is complex (non-immediate)-      * y must go in %ecx.-      * we cannot do y first *and* put its result in %ecx, because-        %ecx might be clobbered by x.-      * if we do y second, then x cannot be-        in a clobbered reg.  Also, we cannot clobber x's reg-        with the instruction itself.-      * so we can either:-        - do y first, put its result in a fresh tmp, then copy it to %ecx later-        - do y second and put its result into %ecx.  x gets placed in a fresh-          tmp.  This is likely to be better, because the reg alloc can-          eliminate this reg->reg move here (it won't eliminate the other one,-          because the move is into the fixed %ecx).-      * in the case of C calls the use of ecx here can interfere with arguments.-        We avoid this with the hack described in Note [Evaluate C-call-        arguments before placing in destination registers]-    -}-    shift_code width instr x y{-amount-} = do-        x_code <- getAnyReg x-        let format = intFormat width-        tmp <- getNewRegNat format-        y_code <- getAnyReg y-        let-           code = x_code tmp `appOL`-                  y_code ecx `snocOL`-                  instr format (OpReg ecx) (OpReg tmp)-        return (Fixed format tmp code)--    ---------------------    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register-    add_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger y-        , rep /= W8 -- LEA doesn't support byte size (#18614)-        = add_int rep x y-    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y-      where format = intFormat rep-    -- TODO: There are other interesting patterns we want to replace-    --     with a LEA, e.g. `(x + offset) + (y << shift)`.--    ---------------------    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register-    sub_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger (-y)-        , rep /= W8 -- LEA doesn't support byte size (#18614)-        = add_int rep x (-y)-    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y--    -- our three-operand add instruction:-    add_int width x y = do-        (x_reg, x_code) <- getSomeReg x-        let-            format = intFormat width-            imm = ImmInt (fromInteger y)-            code dst-               = x_code `snocOL`-                 LEA format-                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))-                        (OpReg dst)-        ---        return (Any format code)--    ------------------------    -- See Note [DIV/IDIV for bytes]-    div_code W8 signed quotient x y = do-        let widen | signed    = MO_SS_Conv W8 W16-                  | otherwise = MO_UU_Conv W8 W16-        div_code-            W16-            signed-            quotient-            (CmmMachOp widen [x])-            (CmmMachOp widen [y])--    div_code width signed quotient x y = do-           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered-           x_code <- getAnyReg x-           let-             format = intFormat width-             widen | signed    = CLTD format-                   | otherwise = XOR format (OpReg edx) (OpReg edx)--             instr | signed    = IDIV-                   | otherwise = DIV--             code = y_code `appOL`-                    x_code eax `appOL`-                    toOL [widen, instr format y_op]--             result | quotient  = eax-                    | otherwise = edx--           return (Fixed format result code)--    ------------------------    -- Vector operations----    vector_float_op_avx :: VectorArithInstns-                        -> Length-                        -> Width-                        -> CmmExpr-                        -> CmmExpr-                        -> NatM Register-    vector_float_op_avx op l w expr1 expr2 = do-      (reg1, exp1) <- getSomeReg expr1-      (reg2, exp2) <- getSomeReg expr2-      let format   = case w of-                       W32 -> VecFormat l FmtFloat-                       W64 -> VecFormat l FmtDouble-                       _ -> pprPanic "Floating-point AVX vector operation not supported at this width"-                             (text "width:" <+> ppr w)-          code dst = case op of-            VA_Add -> arithInstr VADD-            VA_Sub -> arithInstr VSUB-            VA_Mul -> arithInstr VMUL-            VA_Div -> arithInstr VDIV-            VA_Min -> arithInstr (VMINMAX Min FloatMinMax)-            VA_Max -> arithInstr (VMINMAX Max FloatMinMax)-            where-              -- opcode src2 src1 dst <==> dst = src1 `opcode` src2-              arithInstr instr = exp1 `appOL` exp2 `snocOL`-                                 (instr format (OpReg reg2) reg1 dst)-      return (Any format code)--    vector_float_op_sse :: VectorArithInstns-                        -> Length-                        -> Width-                        -> CmmExpr-                        -> CmmExpr-                        -> NatM Register-    vector_float_op_sse op l w expr1 expr2 = do-      -- This function is similar to genTrivialCode, but re-using it would require-      -- handling alignment correctly: SSE vector instructions typically require 16-byte-      -- alignment for their memory operand (this restriction is relaxed with VEX-encoded-      -- instructions).-      -- For now, we always load the value into a register and avoid the alignment issue.-      exp1_code <- getAnyReg expr1-      (reg2, exp2_code) <- getSomeReg expr2-      let format   = case w of-                       W32 -> VecFormat l FmtFloat-                       W64 -> VecFormat l FmtDouble-                       _ -> pprPanic "Floating-point SSE vector operation not supported at this width"-                             (text "width:" <+> ppr w)-      tmp <- getNewRegNat format-      let code dst = case op of-            VA_Add -> arithInstr ADD-            VA_Sub -> arithInstr SUB-            VA_Mul -> arithInstr MUL-            VA_Div -> arithInstr FDIV-            VA_Min -> arithInstr (MINMAX Min FloatMinMax)-            VA_Max -> arithInstr (MINMAX Max FloatMinMax)-            where-              -- opcode src2 src1 <==> src1 = src1 `opcode` src2-              arithInstr instr-                | dst == reg2 = exp2_code `snocOL`-                                (MOVU format (OpReg reg2) (OpReg tmp)) `appOL`-                                exp1_code dst `snocOL`-                                instr format (OpReg tmp) (OpReg dst)-                | otherwise = exp2_code `appOL`-                              exp1_code dst `snocOL`-                              instr format (OpReg reg2) (OpReg dst)-      return (Any format code)-    ---------------------    vector_float_extract :: Length-                         -> Width-                         -> CmmExpr-                         -> CmmExpr-                         -> NatM Register-    vector_float_extract l W32 expr (CmmLit lit) = do-      (r, exp) <- getSomeReg expr-      let format   = VecFormat l FmtFloat-          imm      = litToImm lit-          code dst-            = case lit of-                CmmInt 0 _ -> exp `snocOL` (MOV FF32 (OpReg r) (OpReg dst))-                CmmInt _ _ -> exp `snocOL` (VPSHUFD format imm (OpReg r) dst)-                _          -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit)-      return (Any FF32 code)-    vector_float_extract l W64 expr (CmmLit lit) = do-      (r, exp) <- getSomeReg expr-      let format   = VecFormat l FmtDouble-          code dst-            = case lit of-                CmmInt 0 _ -> exp `snocOL`-                              (MOV FF64 (OpReg r) (OpReg dst))-                CmmInt 1 _ -> exp `snocOL`-                              (MOVHLPS format r dst)-                _          -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit)-      return (Any FF64 code)-    vector_float_extract _ w c e =-      pprPanic "Unsupported AVX floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w)-    -------------------------    vector_float_extract_sse :: Length-                             -> Width-                             -> CmmExpr-                             -> CmmExpr-                             -> NatM Register-    vector_float_extract_sse l W32 expr (CmmLit lit)-      = do-      (r,exp) <- getSomeReg expr-      let format   = VecFormat l FmtFloat-          imm      = litToImm lit-          code dst-            = case lit of-                CmmInt 0 _ -> exp `snocOL` (MOVU format (OpReg r) (OpReg dst))-                CmmInt _ _ -> exp `snocOL` (PSHUFD format imm (OpReg r) dst)-                _          -> pprPanic "Unsupported SSE floating-point vector extract offset" (ppr lit)-      return (Any FF32 code)-    vector_float_extract_sse _ w c e-      = pprPanic "Unsupported SSE floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w)-    -------------------------    vector_int_extract_sse :: Length-                           -> Width-                           -> CmmExpr-                           -> CmmExpr-                           -> NatM Register-    vector_int_extract_sse l@2 W64 expr (CmmLit lit)-      = do-      (r, exp) <- getSomeReg expr-      let fmt = VecFormat l FmtInt64-      tmp <- getNewRegNat fmt-      let code dst =-            case lit of-              CmmInt 0 _ -> exp `snocOL`-                            (MOVD fmt II64 (OpReg r) (OpReg dst))-              CmmInt 1 _ -> exp `snocOL`-                            (MOVHLPS fmt r tmp) `snocOL`-                            (MOVD fmt II64 (OpReg tmp) (OpReg dst))-              _          -> panic "Error in offset while unpacking"-      return (Any II64 code)-    vector_int_extract_sse _ w c e-      = pprPanic "Unsupported SSE floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w)--    vector_shuffle_float :: Length -> Width -> CmmExpr -> CmmExpr -> [Int] -> NatM Register-    vector_shuffle_float l w v1 v2 is = do-      (r1, exp1) <- getSomeReg v1-      (r2, exp2) <- getSomeReg v2-      let fmt = VecFormat l (if w == W32 then FmtFloat else FmtDouble)-          code dst-            = exp1 `appOL` (exp2 `appOL` shuffleInstructions fmt r1 r2 is dst)-      return (Any fmt code)--    shuffleInstructions :: Format -> Reg -> Reg -> [Int] -> Reg -> OrdList Instr-    shuffleInstructions fmt v1 v2 is dst =-      case fmt of-        VecFormat 2 FmtDouble ->-          case is of-            [i1, i2] -> case (i1, i2) of-              (0,0) -> unitOL (VSHUF fmt (ImmInt 0b00) (OpReg v1) v1 dst)-              (1,1) -> unitOL (VSHUF fmt (ImmInt 0b11) (OpReg v1) v1 dst)-              (2,2) -> unitOL (VSHUF fmt (ImmInt 0b00) (OpReg v2) v2 dst)-              (3,3) -> unitOL (VSHUF fmt (ImmInt 0b11) (OpReg v2) v2 dst)-              (0,1) -> unitOL (VMOVU fmt (OpReg v1) (OpReg dst))-              (2,3) -> unitOL (VMOVU fmt (OpReg v2) (OpReg dst))-              (1,0) -> unitOL (VSHUF fmt (ImmInt 0b01) (OpReg v1) v1 dst)-              (3,2) -> unitOL (VSHUF fmt (ImmInt 0b01) (OpReg v2) v2 dst)-              (0,2) -> unitOL (VSHUF fmt (ImmInt 0b00) (OpReg v2) v1 dst)-              (2,0) -> unitOL (VSHUF fmt (ImmInt 0b00) (OpReg v1) v2 dst)-              (0,3) -> unitOL (VSHUF fmt (ImmInt 0b10) (OpReg v2) v1 dst)-              (3,0) -> unitOL (VSHUF fmt (ImmInt 0b01) (OpReg v1) v2 dst)-              (1,2) -> unitOL (VSHUF fmt (ImmInt 0b01) (OpReg v2) v1 dst)-              (2,1) -> unitOL (VSHUF fmt (ImmInt 0b10) (OpReg v1) v2 dst)-              (1,3) -> unitOL (VSHUF fmt (ImmInt 0b11) (OpReg v2) v1 dst)-              (3,1) -> unitOL (VSHUF fmt (ImmInt 0b11) (OpReg v1) v2 dst)-              _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is)-            _ -> pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)-        VecFormat 4 FmtFloat-          -- indices 0 <= i <= 7-          | all ( (>= 0) <&&> (<= 7) ) is ->-          case is of-            [i1, i2, i3, i4]-              | all ( <= 3 ) is-              , let imm = i1 + i2 `shiftL` 2 + i3 `shiftL` 4 + i4 `shiftL` 6-              -> unitOL (VSHUF fmt (ImmInt imm) (OpReg v1) v1 dst)-              | all ( >= 4 ) is-              , let [j1, j2, j3, j4] = map ( subtract 4 ) is-                    imm = j1 + j2 `shiftL` 2 + j3 `shiftL` 4 + j4 `shiftL` 6-              -> unitOL (VSHUF fmt (ImmInt imm) (OpReg v2) v2 dst)-              | i1 <= 3, i2 <= 3-              , i3 >= 4, i4 >= 4-              , let imm = i1 + i2 `shiftL` 2 + (i3 - 4) `shiftL` 4 + (i4 - 4) `shiftL` 6-              -> unitOL (VSHUF fmt (ImmInt imm) (OpReg v2) v1 dst)-              | i1 >= 4, i2 >= 4-              , i3 <= 3, i4 <= 3-              , let imm = (i1 - 4) + (i2 - 4) `shiftL` 2 + i3 `shiftL` 4 + i4 `shiftL` 6-              -> unitOL (VSHUF fmt (ImmInt imm) (OpReg v1) v2 dst)-              | otherwise-              ->-              -- Fall-back code with 4 INSERTPS operations.-              -- SIMD NCG TODO: handle more cases with better lowering.-              let -- bits: ss_dd_zzzz-                  -- ss: pick source location-                  -- dd: pick destination location-                  -- zzzz: pick locations to be zeroed-                  insertImm src dst = shiftL   ( src `mod` 4 ) 6-                                    .|. shiftL dst 4-                  vec src = if src >= 4 then v2 else v1-              in unitOL-                (INSERTPS fmt (ImmInt $ insertImm i1 0 .|. 0b1110) (OpReg $ vec i1) dst)-                `snocOL`-                (INSERTPS fmt (ImmInt $ insertImm i2 1) (OpReg $ vec i2) dst)-                `snocOL`-                (INSERTPS fmt (ImmInt $ insertImm i3 2) (OpReg $ vec i3) dst)-                `snocOL`-                (INSERTPS fmt (ImmInt $ insertImm i4 3) (OpReg $ vec i4) dst)-            _ -> pprPanic "vector shuffle: wrong number of indices (expected 4)" (ppr is)-          | otherwise-          -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 7" (ppr is)-        _ ->-          pprPanic "vector shuffle: unsupported format" (ppr fmt)--getRegister' platform _is32Bit (CmmMachOp mop [x, y, z]) = do -- ternary MachOps-  avx    <- avxEnabled-  sse4_1 <- sse4_1Enabled-  case mop of-      -- Floating point fused multiply-add operations @ ± x*y ± z@-      MO_FMA var l w-        | l * widthInBits w > 256-        -> sorry "Please use -fllvm for wide vector FMA support"-        | otherwise-        -> genFMA3Code l w var x y z--      -- Ternary vector operations-      MO_VF_Insert l W32  | l == 4 -> vector_floatx4_insert_sse sse4_1 x y z-                          | otherwise ->-         sorry $ "FloatX" ++ show l ++ "# insert operations require -fllvm"-           -- SIMD NCG TODO:-           ---           --   - add support for FloatX8, FloatX16.-      MO_VF_Insert l W64  -> vector_double_insert avx l x y z-      MO_V_Insert l W64   -> vector_int_insert_sse l W64 x y z--      _other -> pprPanic "getRegister(x86) - ternary CmmMachOp (1)"-                  (pprMachOp mop)--  where-    -- SIMD NCG TODO:-    ---    --   - add support for FloatX8, FloatX16.-    vector_floatx4_insert_sse :: Bool-                              -> CmmExpr-                              -> CmmExpr-                              -> CmmExpr-                              -> NatM Register-    vector_floatx4_insert_sse sse4_1 vecExpr valExpr (CmmLit (CmmInt offset _))-      | sse4_1 = do-        (r, exp)    <- getNonClobberedReg valExpr-        fn          <- getAnyReg vecExpr-        let fmt      = VecFormat 4 FmtFloat-            imm      = litToImm (CmmInt (offset `shiftL` 4) W32)-            code dst = exp `appOL`-                      (fn dst) `snocOL`-                      (INSERTPS fmt imm (OpReg r) dst)-         in return $ Any fmt code-      | otherwise = do -- SSE <= 3-        (r, exp)    <- getNonClobberedReg valExpr-        fn          <- getAnyReg vecExpr-        let fmt      = VecFormat 4 FmtFloat-        tmp <- getNewRegNat fmt-        let code dst-              = case offset of-                  0 -> exp `appOL`-                      (fn dst) `snocOL`-                      -- The following MOV compiles to MOVSS instruction and merges two vectors-                      (MOV fmt (OpReg r) (OpReg dst))  -- dst <- (r[0],dst[1],dst[2],dst[3])-                  1 -> exp `appOL`-                      (fn dst) `snocOL`-                      (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst-                      (UNPCKL fmt (OpReg r) dst) `snocOL`          -- dst <- (dst[0],r[0],dst[1],r[1])-                      (SHUF fmt (ImmInt 0xe4) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[2],tmp[3])-                  2 -> exp `appOL`-                       (fn dst) `snocOL`-                       (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst-                       (MOV fmt (OpReg r) (OpReg tmp)) `snocOL`     -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS-                       (SHUF fmt (ImmInt 0xc4) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[0],tmp[3])-                  3 -> exp `appOL`-                       (fn dst) `snocOL`-                       (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst-                       (MOV fmt (OpReg r) (OpReg tmp)) `snocOL`     -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS-                       (SHUF fmt (ImmInt 0x24) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[2],tmp[0])-                  _ -> panic "MO_VF_Insert FloatX4: unsupported offset"-         in return $ Any fmt code-    vector_floatx4_insert_sse _ _ _ offset-      = pprPanic "Unsupported vector insert operation" $-          vcat-            [ text "FloatX4#"-            , text "offset:" <+> pdoc platform offset ]---    -- SIMD NCG TODO:-    ---    --   - add support for DoubleX4#, DoubleX8#.-    vector_double_insert :: Bool-                         -> Length-                         -> CmmExpr-                         -> CmmExpr-                         -> CmmExpr-                         -> NatM Register-    -- DoubleX2-    vector_double_insert avx len@2 vecExpr valExpr (CmmLit offset)-      = do-        (valReg, valExp) <- getNonClobberedReg valExpr-        (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction-        let movu = if avx then VMOVU else MOVU-            fmt = VecFormat len FmtDouble-            code dst-              = case offset of-                  CmmInt 0 _ -> valExp `appOL`-                                vecExp `snocOL`-                                (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL`-                                -- The following MOV compiles to MOVSD instruction and merges two vectors-                                (MOV (VecFormat 2 FmtDouble) (OpReg valReg) (OpReg dst))-                  CmmInt 1 _ -> valExp `appOL`-                                vecExp `snocOL`-                                (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL`-                                (SHUF fmt (ImmInt 0b00) (OpReg valReg) dst)-                  _ -> pprPanic "MO_VF_Insert DoubleX2: unsupported offset" (ppr offset)-         in return $ Any fmt code-    vector_double_insert _ _ _ _ _ =-      sorry "Unsupported floating-point vector insert operation; please use -fllvm"-    -- For DoubleX4: use VSHUFPD.-    -- For DoubleX8: use something like vinsertf64x2 followed by vpblendd?--    -- SIMD NCG TODO:-    ---    --   - only supports Int64X2, add support for everything else:-    --     (Int32X{4,2}, Int16X{8,4,2}, Int8X{16,8,4,2})-    vector_int_insert_sse :: HasCallStack => Length-                          -> Width-                          -> CmmExpr-                          -> CmmExpr-                          -> CmmExpr-                          -> NatM Register-    -- Int64X2-    vector_int_insert_sse len@2 W64 vecExpr valExpr (CmmLit offset)-      = do-        (valReg, valExp) <- getNonClobberedReg valExpr-        (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction-        let fmt = VecFormat len FmtInt64-        tmp <- getNewRegNat fmt-        let code dst-              = case offset of-                  CmmInt 0 _ -> valExp `appOL`-                                vecExp `snocOL`-                                (MOVHLPS fmt vecReg tmp) `snocOL`-                                (MOVD II64 fmt (OpReg valReg) (OpReg dst)) `snocOL`-                                (PUNPCKLQDQ fmt (OpReg tmp) dst)-                  CmmInt 1 _ -> valExp `appOL`-                                vecExp `snocOL`-                                (MOVDQU fmt (OpReg vecReg) (OpReg dst)) `snocOL`-                                (MOVD II64 fmt (OpReg valReg) (OpReg tmp)) `snocOL`-                                (PUNPCKLQDQ fmt (OpReg tmp) dst)-                  _ -> pprPanic "MO_V_Insert Int64X2: unsupported offset" (ppr offset)-         in return $ Any fmt code-    vector_int_insert_sse _ _ _ _ _ =-      sorry "Unsupported integer vector insert operation; please use -fllvm"--getRegister' _ _ (CmmMachOp mop (_:_:_:_:_)) =-  pprPanic "getRegister(x86): MachOp with >= 4 arguments" (text $ show mop)--getRegister' platform is32Bit load@(CmmLoad mem ty _)-  | isVecType ty-  = do-    config <- getConfig-    Amode addr mem_code <- getAmode mem-    let code dst =-          mem_code `snocOL`-            movInstr config format (OpAddr addr) (OpReg dst)-    return (Any format code)-  | isFloatType ty-  = do-    Amode addr mem_code <- getAmode mem-    loadAmode (floatFormat width) addr mem_code--  | is32Bit && not (isWord64 ty)-  = do-    let-      instr = case width of-                W8     -> MOVZxL II8-                  -- We always zero-extend 8-bit loads, if we-                  -- can't think of anything better.  This is because-                  -- we can't guarantee access to an 8-bit variant of every register-                  -- (esi and edi don't have 8-bit variants), so to make things-                  -- simpler we do our 8-bit arithmetic with full 32-bit registers.-                _other -> MOV format-    code <- intLoadCode instr mem-    return (Any format code)--  | not is32Bit-  -- Simpler memory load code on x86_64-  = do-    code <- intLoadCode (MOV format) mem-    return (Any format code)--  | otherwise-  = pprPanic "getRegister(x86) CmmLoad" (pdoc platform load)-  where-    format = cmmTypeFormat ty-    width = typeWidth ty---- Handle symbol references with LEA and %rip-relative addressing.--- See Note [%rip-relative addressing on x86-64].-getRegister' platform is32Bit (CmmLit lit)-  | is_label lit-  , not is32Bit-  = do let format = cmmTypeFormat (cmmLitType platform lit)-           imm = litToImm lit-           op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm)-           code dst = unitOL (LEA format op (OpReg dst))-       return (Any format code)-  where-    is_label (CmmLabel {})        = True-    is_label (CmmLabelOff {})     = True-    is_label (CmmLabelDiffOff {}) = True-    is_label _                    = False--getRegister' platform is32Bit (CmmLit lit) = do-  avx <- avxEnabled--  -- NB: it is important that the code produced here (to load a literal into-  -- a register) doesn't clobber any registers other than the destination-  -- register; the code for generating C calls relies on this property.-  ---  -- In particular, we have:-  ---  -- > loadIntoRegMightClobberOtherReg (CmmLit _) = False-  ---  -- which means that we assume that loading a literal into a register-  -- will not clobber any other registers.--  -- TODO: this function mishandles floating-point negative zero,-  -- because -0.0 == 0.0 returns True and because we represent CmmFloat as-  -- Rational, which can't properly represent negative zero.--  if-    -- Zero: use XOR.-    | isZeroLit lit-    -> let code dst-             | isIntFormat fmt-             = let fmt'-                     | is32Bit-                     = fmt-                     | otherwise-                     -- x86_64: 32-bit xor is one byte shorter,-                     -- and zero-extends to 64 bits-                     = case fmt of-                         II64 -> II32-                         _ -> fmt-               in unitOL (XOR fmt' (OpReg dst) (OpReg dst))-             | avx-             = if float_or_floatvec-               then unitOL (VXOR fmt (OpReg dst) dst dst)-               else unitOL (VPXOR fmt dst dst dst)-             | otherwise-             = if float_or_floatvec-               then unitOL (XOR fmt (OpReg dst) (OpReg dst))-               else unitOL (PXOR fmt (OpReg dst) dst)-       in return $ Any fmt code--    -- Constant vector: use broadcast.-    | VecFormat l sFmt <- fmt-    , CmmVec (f:fs) <- lit-    , all (== f) fs-    -> do let w = scalarWidth sFmt-              broadcast = if isFloatScalarFormat sFmt-                          then MO_VF_Broadcast l w-                          else MO_V_Broadcast l w-          valCode <- getAnyReg (CmmMachOp broadcast [CmmLit f])-          return $ Any fmt valCode--    -- Optimisation for loading small literals on x86_64: take advantage-    -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit-    -- instruction forms are shorter.-    | not is32Bit, isWord64 cmmTy, not (isBigLit lit)-    -> let-          imm = litToImm lit-          code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))-      in-          return (Any II64 code)--    -- Scalar integer: use an immediate.-    | isIntFormat fmt-    -> let imm = litToImm lit-           code dst = unitOL (MOV fmt (OpImm imm) (OpReg dst))-       in return (Any fmt code)--    -- General case: load literal from data address.-    | otherwise-    -> do let w = formatToWidth fmt-          Amode addr addr_code <- memConstant (mkAlignment $ widthInBytes w) lit-          loadAmode fmt addr addr_code--    where-      cmmTy = cmmLitType platform lit-      fmt = cmmTypeFormat cmmTy-      float_or_floatvec = isFloatOrFloatVecFormat fmt-      isZeroLit (CmmInt i _) = i == 0-      isZeroLit (CmmFloat f _) = f == 0 -- TODO: mishandles negative zero-      isZeroLit (CmmVec fs) = all isZeroLit fs-      isZeroLit _ = False--      isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff-      isBigLit _ = False-        -- note1: not the same as (not.is32BitLit), because that checks for-        -- signed literals that fit in 32 bits, but we want unsigned-        -- literals here.-        -- note2: all labels are small, because we're assuming the-        -- small memory model. See Note [%rip-relative addressing on x86-64].--getRegister' platform _ slot@(CmmStackSlot {}) =-  pprPanic "getRegister(x86) CmmStackSlot" (pdoc platform slot)--intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr-   -> NatM (Reg -> InstrBlock)-intLoadCode instr mem = do-  Amode src mem_code <- getAmode mem-  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))---- Compute an expression into *any* register, adding the appropriate--- move instruction if necessary.-getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock)-getAnyReg expr = do-  r <- getRegister expr-  anyReg r--anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock)-anyReg (Any _ code)          = return code-anyReg (Fixed rep reg fcode) = do-  config <- getConfig-  return (\dst -> fcode `snocOL` mkRegRegMoveInstr config rep reg dst)---- A bit like getSomeReg, but we want a reg that can be byte-addressed.--- Fixed registers might not be byte-addressable, so we make sure we've--- got a temporary, inserting an extra reg copy if necessary.-getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)-getByteReg expr = do-  config <- getConfig-  is32Bit <- is32BitPlatform-  if is32Bit-      then do r <- getRegister expr-              case r of-                Any rep code -> do-                    tmp <- getNewRegNat rep-                    return (tmp, code tmp)-                Fixed rep reg code-                    | isVirtualReg reg -> return (reg,code)-                    | otherwise -> do-                        tmp <- getNewRegNat rep-                        return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp)-                    -- ToDo: could optimise slightly by checking for-                    -- byte-addressable real registers, but that will-                    -- happen very rarely if at all.-      else getSomeReg expr -- all regs are byte-addressable on x86_64---- Another variant: this time we want the result in a register that cannot--- be modified by code to evaluate an arbitrary expression.-getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)-getNonClobberedReg expr = do-  r <- getRegister expr-  config <- getConfig-  let platform = ncgPlatform config-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed rep reg code-        -- only certain regs can be clobbered-        | reg `elem` instrClobberedRegs platform-        -> do-                tmp <- getNewRegNat rep-                return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp)-        | otherwise ->-                return (reg, code)-------------------------------------------------------------------------------------- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.------ An 'Amode' is a datatype representing a valid address form for the target--- (e.g. "Base + Index + disp" or immediate) and the code to compute it.-getAmode :: CmmExpr -> NatM Amode-getAmode e = do-   platform <- getPlatform-   let is32Bit = target32Bit platform--   case e of-      CmmRegOff r n-         -> getAmode $ mangleIndexTree r n--      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), CmmLit displacement]-         | not is32Bit-         -> return $ Amode (ripRel (litToImm displacement)) nilOL--      -- This is all just ridiculous, since it carefully undoes-      -- what mangleIndexTree has just done.-      CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]-         | is32BitLit platform lit-         -- assert (rep == II32)???-         -> do-            (x_reg, x_code) <- getSomeReg x-            let off = ImmInt (-(fromInteger i))-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)--      CmmMachOp (MO_Add _rep) [x, CmmLit lit]-         | is32BitLit platform lit-         -- assert (rep == II32)???-         -> do-            (x_reg, x_code) <- getSomeReg x-            let off = litToImm lit-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)--      -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be-      -- recognised by the next rule.-      CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]-         -> getAmode (CmmMachOp (MO_Add rep) [b,a])--      -- Matches: (x + offset) + (y << shift)-      CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]-         | shift == 0 || shift == 1 || shift == 2 || shift == 3-         -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)--      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]-         | shift == 0 || shift == 1 || shift == 2 || shift == 3-         -> x86_complex_amode x y shift 0--      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)-                                                    [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]-         | shift == 0 || shift == 1 || shift == 2 || shift == 3-         && is32BitInteger offset-         -> x86_complex_amode x y shift offset--      CmmMachOp (MO_Add _) [x,y]-         | not (isLit y) -- we already handle valid literals above.-         -> x86_complex_amode x y 0 0--      CmmLit lit@(CmmFloat {})-        -> pprPanic "X86 CodeGen: attempt to use floating-point value as a memory address"-             (ppr lit)--      -- Handle labels with %rip-relative addressing since in general the image-      -- may be loaded anywhere in the 64-bit address space (e.g. on Windows-      -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64].-      CmmLit lit-         | not is32Bit-         , is_label lit-         -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL)--      CmmLit lit-         | is32BitLit platform lit-         -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)--      -- Literal with offsets too big (> 32 bits) fails during the linking phase-      -- (#15570). We already handled valid literals above so we don't have to-      -- test anything here.-      CmmLit (CmmLabelOff l off)-         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)-                                             , CmmLit (CmmInt (fromIntegral off) W64)-                                             ])-      CmmLit (CmmLabelDiffOff l1 l2 off w)-         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)-                                             , CmmLit (CmmInt (fromIntegral off) W64)-                                             ])--      -- in case we can't do something better, we just compute the expression-      -- and put the result in a register-      _ -> do-        (reg,code) <- getSomeReg e-        return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)-  where-    is_label (CmmLabel{}) = True-    is_label (CmmLabelOff{}) = True-    is_label (CmmLabelDiffOff{}) = True-    is_label _ = False----- | Like 'getAmode', but on 32-bit use simple register addressing--- (i.e. no index register). This stops us from running out of--- registers on x86 when using instructions such as cmpxchg, which can--- use up to three virtual registers and one fixed register.-getSimpleAmode :: CmmExpr -> NatM Amode-getSimpleAmode addr = is32BitPlatform >>= \case-  False -> getAmode addr-  True  -> do-    addr_code <- getAnyReg addr-    config <- getConfig-    addr_r <- getNewRegNat (intFormat (ncgWordWidth config))-    let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)-    return $! Amode amode (addr_code addr_r)--x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode-x86_complex_amode base index shift offset-  = do (x_reg, x_code) <- getNonClobberedReg base-        -- x must be in a temp, because it has to stay live over y_code-        -- we could compare x_reg and y_reg and do something better here...-       (y_reg, y_code) <- getSomeReg index-       let-           code = x_code `appOL` y_code-           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;-                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"-       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))-               code)------- -------------------------------------------------------------------------------- getOperand: sometimes any operand will do.---- getNonClobberedOperand: the value of the operand will remain valid across--- the computation of an arbitrary expression, unless the expression--- is computed directly into a register which the operand refers to--- (see trivialCode where this function is used for an example).--getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand (CmmLit lit) =-  if isSuitableFloatingPointLit lit-  then do-    let CmmFloat _ w = lit-    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-    return (OpAddr addr, code)-  else do-    platform <- getPlatform-    if is32BitLit platform lit && isIntFormat (cmmTypeFormat (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getNonClobberedOperand_generic (CmmLit lit)--getNonClobberedOperand (CmmLoad mem ty _) = do-  is32Bit <- is32BitPlatform-  -- this logic could be simplified-  -- TODO FIXME-  if   (if is32Bit then not (isWord64 ty) else True)-      -- if 32bit and ty is at float/double/simd value-      -- or if 64bit-      --  this could use some eyeballs or i'll need to stare at it more later-    then do-      platform <- ncgPlatform <$> getConfig-      Amode src mem_code <- getAmode mem-      (src',save_code) <--        if (amodeCouldBeClobbered platform src)-                then do-                   tmp <- getNewRegNat (archWordFormat is32Bit)-                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),-                           unitOL (LEA (archWordFormat is32Bit)-                                       (OpAddr src)-                                       (OpReg tmp)))-                else-                   return (src, nilOL)-      return (OpAddr src', mem_code `appOL` save_code)-    else-      -- if its a word or gcptr on 32bit?-      getNonClobberedOperand_generic (CmmLoad mem ty NaturallyAligned)--getNonClobberedOperand e = getNonClobberedOperand_generic e--getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand_generic e = do-  (reg, code) <- getNonClobberedReg e-  return (OpReg reg, code)--amodeCouldBeClobbered :: Platform -> AddrMode -> Bool-amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)--regClobbered :: Platform -> Reg -> Bool-regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr-regClobbered _ _ = False---- getOperand: the operand is not required to remain valid across the--- computation of an arbitrary expression.-getOperand :: CmmExpr -> NatM (Operand, InstrBlock)--getOperand (CmmLit lit) = do-  if isSuitableFloatingPointLit lit-    then do-      let CmmFloat _ w = lit-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-      return (OpAddr addr, code)-    else do--  platform <- getPlatform-  if is32BitLit platform lit && (isIntFormat $ cmmTypeFormat (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getOperand_generic (CmmLit lit)--getOperand (CmmLoad mem ty _) = do-  is32Bit <- is32BitPlatform-  if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True)-     then do-       Amode src mem_code <- getAmode mem-       return (OpAddr src, mem_code)-     else-       getOperand_generic (CmmLoad mem ty NaturallyAligned)--getOperand e = getOperand_generic e--getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getOperand_generic e = do-    (reg, code) <- getSomeReg e-    return (OpReg reg, code)--isOperand :: Platform -> CmmExpr -> Bool-isOperand _ (CmmLoad _ _ _) = True-isOperand platform (CmmLit lit)-                          = is32BitLit platform lit-                          || isSuitableFloatingPointLit lit-isOperand _ _            = False---- | Given a 'Register', produce a new 'Register' with an instruction block--- which will check the value for alignment. Used for @-falignment-sanitisation@.-addAlignmentCheck :: Int -> Register -> Register-addAlignmentCheck align reg =-    case reg of-      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)-      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)-  where-    check :: Format -> Reg -> InstrBlock-    check fmt reg =-        assert (isIntFormat fmt) $-        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)-             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel-             ]--memConstant :: Alignment -> CmmLit -> NatM Amode-memConstant align lit = do-  lbl <- getNewLabelNat-  let rosection = Section ReadOnlyData lbl-  config <- getConfig-  platform <- getPlatform-  (addr, addr_code) <- if target32Bit platform-                       then do dynRef <- cmmMakeDynamicReference-                                             config-                                             DataReference-                                             lbl-                               Amode addr addr_code <- getAmode dynRef-                               return (addr, addr_code)-                       else return (ripRel (ImmCLbl lbl), nilOL)-  let code =-        LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])-        `consOL` addr_code-  return (Amode addr code)---- | Load the value at the given address into any register.-loadAmode :: Format -> AddrMode -> InstrBlock -> NatM Register-loadAmode fmt addr addr_code = do-  config <- getConfig-  let load dst = movInstr config fmt (OpAddr addr) (OpReg dst)-  return $ Any fmt (\ dst -> addr_code `snocOL` load dst)---- if we want a floating-point literal as an operand, we can--- use it directly from memory.  However, if the literal is--- zero, we're better off generating it into a register using--- xor.-isSuitableFloatingPointLit :: CmmLit -> Bool-isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0-isSuitableFloatingPointLit _ = False--getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)-getRegOrMem e@(CmmLoad mem ty _) = do-  is32Bit <- is32BitPlatform-  if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True)-     then do-       Amode src mem_code <- getAmode mem-       return (OpAddr src, mem_code)-     else do-       (reg, code) <- getNonClobberedReg e-       return (OpReg reg, code)-getRegOrMem e = do-    (reg, code) <- getNonClobberedReg e-    return (OpReg reg, code)--is32BitLit :: Platform -> CmmLit -> Bool-is32BitLit platform _lit-   | target32Bit platform = True-is32BitLit platform lit =-   case lit of-      CmmInt i W64              -> is32BitInteger i-      -- Except on Windows, assume that labels are in the range 0-2^31-1: this-      -- assumes the small memory model. Note [%rip-relative addressing on-      -- x86-64].-      CmmLabel _                -> low_image-      -- however we can't assume that label offsets are in this range-      -- (see #15570)-      CmmLabelOff _ off         -> low_image && is32BitInteger (fromIntegral off)-      CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off)-      _                         -> True-  where-    -- Is the executable image certain to be located below 4GB? As noted in-    -- Note [%rip-relative addressing on x86-64], this is not true on Windows.-    low_image =-      case platformOS platform of-        OSMinGW32 -> False   -- See Note [%rip-relative addressing on x86-64]-        _         -> True----- Set up a condition code for a conditional branch.--getCondCode :: CmmExpr -> NatM CondCode---- yes, they really do seem to want exactly the same!--getCondCode (CmmMachOp mop [x, y])-  =-    case mop of-      MO_F_Eq W32 -> condFltCode EQQ x y-      MO_F_Ne W32 -> condFltCode NE  x y-      MO_F_Gt W32 -> condFltCode GTT x y-      MO_F_Ge W32 -> condFltCode GE  x y-      -- Invert comparison condition and swap operands-      -- See Note [SSE Parity Checks]-      MO_F_Lt W32 -> condFltCode GTT  y x-      MO_F_Le W32 -> condFltCode GE   y x--      MO_F_Eq W64 -> condFltCode EQQ x y-      MO_F_Ne W64 -> condFltCode NE  x y-      MO_F_Gt W64 -> condFltCode GTT x y-      MO_F_Ge W64 -> condFltCode GE  x y-      MO_F_Lt W64 -> condFltCode GTT y x-      MO_F_Le W64 -> condFltCode GE  y x--      _ -> condIntCode (machOpToCond mop) x y--getCondCode other = do-   platform <- getPlatform-   pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)--machOpToCond :: MachOp -> Cond-machOpToCond mo = case mo of-  MO_Eq _   -> EQQ-  MO_Ne _   -> NE-  MO_S_Gt _ -> GTT-  MO_S_Ge _ -> GE-  MO_S_Lt _ -> LTT-  MO_S_Le _ -> LE-  MO_U_Gt _ -> GU-  MO_U_Ge _ -> GEU-  MO_U_Lt _ -> LU-  MO_U_Le _ -> LEU-  _other -> pprPanic "machOpToCond" (pprMachOp mo)--{-  Note [64-bit integer comparisons on 32-bit]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--    When doing these comparisons there are 2 kinds of-    comparisons.--    * Comparison for equality (or lack thereof)--    We use xor to check if high/low bits are-    equal. Then combine the results using or.--    * Other comparisons:--    We first compare the low registers-    and use a subtraction with borrow to compare the high registers.--    For signed numbers the condition is determined by-    the sign and overflow flags agreeing or not-    and for unsigned numbers the condition is the carry flag.---}---- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be--- passed back up the tree.--condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condIntCode cond x y = do platform <- getPlatform-                          condIntCode' platform cond x y--condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode---- 64-bit integer comparisons on 32-bit--- See Note [64-bit integer comparisons on 32-bit]-condIntCode' platform cond x y-  | target32Bit platform && isWord64 (cmmExprType platform x) = do--  RegCode64 code1 r1hi r1lo <- iselExpr64 x-  RegCode64 code2 r2hi r2lo <- iselExpr64 y--  -- we mustn't clobber r1/r2 so we use temporaries-  tmp1 <- getNewRegNat II32-  tmp2 <- getNewRegNat II32--  let (cond', cmpCode) = intComparison cond r1hi r1lo r2hi r2lo tmp1 tmp2-  return $ CondCode False cond' (code1 `appOL` code2 `appOL` cmpCode)--  where-    intComparison cond r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =-      case cond of-        -- These don't occur as argument of condIntCode'-        ALWAYS  -> panic "impossible"-        NEG     -> panic "impossible"-        POS     -> panic "impossible"-        CARRY   -> panic "impossible"-        OFLO    -> panic "impossible"-        PARITY  -> panic "impossible"-        NOTPARITY -> panic "impossible"-        -- Special case #1 x == y and x != y-        EQQ -> (EQQ, cmpExact)-        NE  -> (NE, cmpExact)-        -- [x >= y]-        GE  -> (GE, cmpGE)-        GEU -> (GEU, cmpGE)-        -- [x >  y]-        GTT -> (LTT, cmpLE)-        GU  -> (LU, cmpLE)-        -- [x <= y]-        LE  -> (GE, cmpLE)-        LEU -> (GEU, cmpLE)-        -- [x <  y]-        LTT -> (LTT, cmpGE)-        LU  -> (LU, cmpGE)-      where-        cmpExact :: OrdList Instr-        cmpExact =-          toOL-            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)-            , MOV II32 (OpReg r1_lo) (OpReg tmp2)-            , XOR II32 (OpReg r2_hi) (OpReg tmp1)-            , XOR II32 (OpReg r2_lo) (OpReg tmp2)-            , OR  II32 (OpReg tmp1)  (OpReg tmp2)-            ]-        cmpGE = toOL-            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)-            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)-            , SBB II32 (OpReg r2_hi) (OpReg tmp1)-            ]-        cmpLE = toOL-            [ MOV II32 (OpReg r2_hi) (OpReg tmp1)-            , CMP II32 (OpReg r1_lo) (OpReg r2_lo)-            , SBB II32 (OpReg r1_hi) (OpReg tmp1)-            ]---- memory vs immediate-condIntCode' platform cond (CmmLoad x ty _) (CmmLit lit)- | is32BitLit platform lit = do-    Amode x_addr x_code <- getAmode x-    let-        imm  = litToImm lit-        code = x_code `snocOL`-                  CMP (cmmTypeFormat ty) (OpImm imm) (OpAddr x_addr)-    ---    return (CondCode False cond code)---- anything vs zero, using a mask--- TODO: Add some sanity checking!!!!-condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 ty))-    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit-    = do-      (x_reg, x_code) <- getSomeReg x-      let-         code = x_code `snocOL`-                TEST (intFormat ty) (OpImm (ImmInteger mask)) (OpReg x_reg)-      ---      return (CondCode False cond code)---- anything vs zero-condIntCode' _ cond x (CmmLit (CmmInt 0 ty)) = do-    (x_reg, x_code) <- getSomeReg x-    let-        code = x_code `snocOL`-                  TEST (intFormat ty) (OpReg x_reg) (OpReg x_reg)-    ---    return (CondCode False cond code)---- anything vs operand-condIntCode' platform cond x y- | isOperand platform y = do-    (x_reg, x_code) <- getNonClobberedReg x-    (y_op,  y_code) <- getOperand y-    let-        code = x_code `appOL` y_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)-    return (CondCode False cond code)--- operand vs. anything: invert the comparison so that we can use a--- single comparison instruction.- | isOperand platform x- , Just revcond <- maybeFlipCond cond = do-    (y_reg, y_code) <- getNonClobberedReg y-    (x_op,  x_code) <- getOperand x-    let-        code = y_code `appOL` x_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)-    return (CondCode False revcond code)---- anything vs anything-condIntCode' platform cond x y = do-  (y_reg, y_code) <- getNonClobberedReg y-  (x_op, x_code) <- getRegOrMem x-  let-        code = y_code `appOL`-               x_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op-  return (CondCode False cond code)-------------------------------------------------------------------------------------condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode--condFltCode cond x y-  =  condFltCode_sse2-  where---  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be-  -- an operand, but the right must be a reg.  We can probably do better-  -- than this general case...-  condFltCode_sse2 = do-    platform <- getPlatform-    (x_reg, x_code) <- getNonClobberedReg x-    (y_op, y_code) <- getOperand y-    let-        code = x_code `appOL`-               y_code `snocOL`-                  CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)-        -- NB(1): we need to use the unsigned comparison operators on the-        -- result of this comparison.-    return (CondCode True (condToUnsigned cond) code)---- -------------------------------------------------------------------------------- Generating assignments---- Assignments are really at the heart of the whole code generation--- business.  Almost all top-level nodes of any real importance are--- assignments, which correspond to loads, stores, or register--- transfers.  If we're really lucky, some of the register transfers--- will go away, because we can use the destination register to--- complete the code generation for the right hand side.  This only--- fails when the right hand side is forced into a fixed register--- (e.g. the result of a call).--assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_IntCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock--assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_FltCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock--assignMem_VecCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_VecCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock---- integer assignment to memory---- specific case of adding/subtracting an integer to a particular address.--- ToDo: catch other cases where we can use an operation directly on a memory--- address.-assignMem_IntCode ty addr (CmmMachOp op [CmmLoad addr2 _ _,-                                                 CmmLit (CmmInt i _)])-   | addr == addr2, ty /= II64 || is32BitInteger i,-     Just instr <- check op-   = do Amode amode code_addr <- getAmode addr-        let code = code_addr `snocOL`-                   instr ty (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)-        return code-   where-        check (MO_Add _) = Just ADD-        check (MO_Sub _) = Just SUB-        check _ = Nothing-        -- ToDo: more?---- general case-assignMem_IntCode ty addr src = do-    platform <- getPlatform-    Amode addr code_addr <- getAmode addr-    (code_src, op_src)   <- get_op_RI platform src-    let-        code = code_src `appOL`-               code_addr `snocOL`-                  MOV ty op_src (OpAddr addr)-        -- NOTE: op_src is stable, so it will still be valid-        -- after code_addr.  This may involve the introduction-        -- of an extra MOV to a temporary register, but we hope-        -- the register allocator will get rid of it.-    ---    return code-  where-    get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator-    get_op_RI platform (CmmLit lit) | is32BitLit platform lit-      = return (nilOL, OpImm (litToImm lit))-    get_op_RI _ op-      = do (reg,code) <- getNonClobberedReg op-           return (code, OpReg reg)----- Assign; dst is a reg, rhs is mem-assignReg_IntCode reg (CmmLoad src _ _) = do-  let ty = cmmTypeFormat $ cmmRegType reg-  load_code <- intLoadCode (MOV ty) src-  platform <- ncgPlatform <$> getConfig-  return (load_code (getRegisterReg platform reg))---- dst is a reg, but src could be anything-assignReg_IntCode reg src = do-  platform <- ncgPlatform <$> getConfig-  code <- getAnyReg src-  return (code (getRegisterReg platform reg))----- Floating point assignment to memory-assignMem_FltCode ty addr src = do-  (src_reg, src_code) <- getNonClobberedReg src-  Amode addr addr_code <- getAmode addr-  let-        code = src_code `appOL`-               addr_code `snocOL`-               MOV ty (OpReg src_reg) (OpAddr addr)--  return code---- Floating point assignment to a register/temporary-assignReg_FltCode reg src = do-  src_code <- getAnyReg src-  platform <- ncgPlatform <$> getConfig-  return (src_code (getRegisterReg platform reg))---- Vector assignment to a register/temporary-assignMem_VecCode ty addr src = do-  (src_reg, src_code) <- getNonClobberedReg src-  Amode addr addr_code <- getAmode addr-  config <- getConfig-  let-    code = src_code `appOL`-           addr_code `snocOL`-           movInstr config ty (OpReg src_reg) (OpAddr addr)-  return code--assignReg_VecCode reg src = do-  platform <- ncgPlatform <$> getConfig-  src_code <- getAnyReg src-  return (src_code (getRegisterReg platform reg))--genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> NatM InstrBlock--genJump (CmmLoad mem _ _) regs = do-  Amode target code <- getAmode mem-  return (code `snocOL` JMP (OpAddr target) regs)--genJump (CmmLit lit) regs =-  return (unitOL (JMP (OpImm (litToImm lit)) regs))--genJump expr regs = do-  (reg,code) <- getSomeReg expr-  return (code `snocOL` JMP (OpReg reg) regs)----- --------------------------------------------------------------------------------  Unconditional branches--genBranch :: BlockId -> InstrBlock-genBranch = toOL . mkJumpInstr------ --------------------------------------------------------------------------------  Conditional jumps/branches--{--Conditional jumps are always to local labels, so we can use branch-instructions.  We peek at the arguments to decide what kind of-comparison to do.--I386: First, we have to ensure that the condition-codes are set according to the supplied comparison operation.--}--genCondBranch-    :: BlockId      -- the source of the jump-    -> BlockId      -- the true branch target-    -> BlockId      -- the false branch target-    -> CmmExpr      -- the condition on which to branch-    -> NatM InstrBlock -- Instructions--genCondBranch bid id false expr = do-  is32Bit <- is32BitPlatform-  genCondBranch' is32Bit bid id false expr---- | We return the instructions generated.-genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr-               -> NatM InstrBlock--genCondBranch' _ bid id false bool = do-  CondCode is_float cond cond_code <- getCondCode bool-  if not is_float-    then-        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)-    else do-        -- See Note [SSE Parity Checks]-        let jmpFalse = genBranch false-            code-                = case cond of-                  NE  -> or_unordered-                  GU  -> plain_test-                  GEU -> plain_test-                  -- Use ASSERT so we don't break releases if-                  -- LTT/LE creep in somehow.-                  LTT ->-                    assertPpr False (text "Should have been turned into >")-                    and_ordered-                  LE  ->-                    assertPpr False (text "Should have been turned into >=")-                    and_ordered-                  _   -> and_ordered--            plain_test = unitOL (-                  JXX cond id-                ) `appOL` jmpFalse-            or_unordered = toOL [-                  JXX cond id,-                  JXX PARITY id-                ] `appOL` jmpFalse-            and_ordered = toOL [-                  JXX PARITY false,-                  JXX cond id,-                  JXX ALWAYS false-                ]-        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)-        return (cond_code `appOL` code)--{-  Note [Introducing cfg edges inside basic blocks]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--    During instruction selection a statement `s`-    in a block B with control of the sort: B -> C-    will sometimes result in control-    flow of the sort:--            ┌ < ┐-            v   ^-      B ->  B1  ┴ -> C--    as is the case for some atomic operations.--    Now to keep the CFG in sync when introducing B1 we clearly-    want to insert it between B and C. However there is-    a catch when we have to deal with self loops.--    We might start with code and a CFG of these forms:--    loop:-        stmt1               ┌ < ┐-        ....                v   ^-        stmtX              loop ┘-        stmtY-        ....-        goto loop:--    Now we introduce B1:-                            ┌ ─ ─ ─ ─ ─┐-        loop:               │   ┌ <  ┐ │-        instrs              v   │    │ ^-        ....               loop ┴ B1 ┴ ┘-        instrsFromX-        stmtY-        goto loop:--    This is simple, all outgoing edges from loop now simply-    start from B1 instead and the code generator knows which-    new edges it introduced for the self loop of B1.--    Disaster strikes if the statement Y follows the same pattern.-    If we apply the same rule that all outgoing edges change then-    we end up with:--        loop ─> B1 ─> B2 ┬─┐-          │      │    └─<┤ │-          │      └───<───┘ │-          └───────<────────┘--    This is problematic. The edge B1->B1 is modified as expected.-    However the modification is wrong!--    The assembly in this case looked like this:--    _loop:-        <instrs>-    _B1:-        ...-        cmpxchgq ...-        jne _B1-        <instrs>-        <end _B1>-    _B2:-        ...-        cmpxchgq ...-        jne _B2-        <instrs>-        jmp loop--    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.--    The problem here is that really B1 should be two basic blocks.-    Otherwise we have control flow in the *middle* of a basic block.-    A contradiction!--    So to account for this we add yet another basic block marker:--    _B:-        <instrs>-    _B1:-        ...-        cmpxchgq ...-        jne _B1-        jmp _B1'-    _B1':-        <instrs>-        <end _B1>-    _B2:-        ...--    Now when inserting B2 we will only look at the outgoing edges of B1' and-    everything will work out nicely.--    You might also wonder why we don't insert jumps at the end of _B1'. There is-    no way another block ends up jumping to the labels _B1 or _B2 since they are-    essentially invisible to other blocks. View them as control flow labels local-    to the basic block if you'd like.--    Not doing this ultimately caused (part 2 of) #17334.--}----- --------------------------------------------------------------------------------  Generating C calls---- Now the biggest nightmare---calls.  Most of the nastiness is buried in--- @get_arg@, which moves the arguments to the correct registers/stack--- locations.  Apart from that, the code is easy.------ (If applicable) Do not fill the delay slots here; you will confuse the--- register allocator.------ See Note [Keeping track of the current block] for information why we need--- to take/return a block id.--genForeignCall-    :: ForeignTarget -- ^ function to call-    -> [CmmFormal]   -- ^ where to put the result-    -> [CmmActual]   -- ^ arguments (of mixed type)-    -> BlockId       -- ^ The block we are in-    -> NatM (InstrBlock, Maybe BlockId)--genForeignCall target dst args bid = do-  case target of-    PrimTarget prim         -> genPrim bid prim dst args-    ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args--genPrim-    :: BlockId       -- ^ The block we are in-    -> CallishMachOp -- ^ MachOp-    -> [CmmFormal]   -- ^ where to put the result-    -> [CmmActual]   -- ^ arguments (of mixed type)-    -> NatM (InstrBlock, Maybe BlockId)---- First we deal with cases which might introduce new blocks in the stream.-genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n]-  = genAtomicRMW bid width amop dst addr n-genPrim bid (MO_Ctz width) [dst] [src]-  = genCtz bid width dst src---- Then we deal with cases which not introducing new blocks in the stream.-genPrim bid prim dst args-  = (,Nothing) <$> genSimplePrim bid prim dst args--genSimplePrim-    :: BlockId       -- ^ the block we are in-    -> CallishMachOp -- ^ MachOp-    -> [CmmFormal]   -- ^ where to put the result-    -> [CmmActual]   -- ^ arguments (of mixed type)-    -> NatM InstrBlock-genSimplePrim bid (MO_Memcpy align)    []      [dst,src,n]    = genMemCpy  bid align dst src n-genSimplePrim bid (MO_Memmove align)   []      [dst,src,n]    = genMemMove bid align dst src n-genSimplePrim bid (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  bid align res dst src n-genSimplePrim bid (MO_Memset align)    []      [dst,c,n]      = genMemSet  bid align dst c n-genSimplePrim _   MO_AcquireFence      []      []             = return nilOL -- barriers compile to no code on x86/x86-64;-genSimplePrim _   MO_ReleaseFence      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.-genSimplePrim _   MO_SeqCstFence       []      []             = return $ unitOL MFENCE-genSimplePrim _   MO_Touch             []      [_]            = return nilOL-genSimplePrim _   (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src-genSimplePrim _   (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src-genSimplePrim bid (MO_BRev width)      [dst]   [src]          = genBitRev bid width dst src-genSimplePrim bid (MO_PopCnt width)    [dst]   [src]          = genPopCnt bid width dst src-genSimplePrim bid (MO_Pdep width)      [dst]   [src,mask]     = genPdep bid width dst src mask-genSimplePrim bid (MO_Pext width)      [dst]   [src,mask]     = genPext bid width dst src mask-genSimplePrim bid (MO_Clz width)       [dst]   [src]          = genClz bid width dst src-genSimplePrim bid (MO_UF_Conv width)   [dst]   [src]          = genWordToFloat bid width dst src-genSimplePrim _   (MO_AtomicRead w mo)  [dst]  [addr]         = genAtomicRead w mo dst addr-genSimplePrim _   (MO_AtomicWrite w mo) []     [addr,val]     = genAtomicWrite w mo addr val-genSimplePrim bid (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg bid width dst addr old new-genSimplePrim _   (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value-genSimplePrim _   (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y-genSimplePrim _   (MO_SubWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y-genSimplePrim _   (MO_AddIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO  r c x y-genSimplePrim _   (MO_SubIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) OFLO  r c x y-genSimplePrim _   (MO_Add2 w)          [h,l]   [x,y]          = genAddWithCarry w h l x y-genSimplePrim _   (MO_U_Mul2 w)        [h,l]   [x,y]          = genUnsignedLargeMul w h l x y-genSimplePrim _   (MO_S_Mul2 w)        [c,h,l] [x,y]          = genSignedLargeMul w c h l x y-genSimplePrim _   (MO_S_QuotRem w)     [q,r]   [x,y]          = genQuotRem w True  q r Nothing   x  y-genSimplePrim _   (MO_U_QuotRem w)     [q,r]   [x,y]          = genQuotRem w False q r Nothing   x  y-genSimplePrim _   (MO_U_QuotRem2 w)    [q,r]   [hx,lx,y]      = genQuotRem w False q r (Just hx) lx y-genSimplePrim _   MO_F32_Fabs          [dst]   [src]          = genFloatAbs W32 dst src-genSimplePrim _   MO_F64_Fabs          [dst]   [src]          = genFloatAbs W64 dst src-genSimplePrim _   MO_F32_Sqrt          [dst]   [src]          = genFloatSqrt FF32 dst src-genSimplePrim _   MO_F64_Sqrt          [dst]   [src]          = genFloatSqrt FF64 dst src-genSimplePrim bid MO_F32_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sinf") [dst] [src]-genSimplePrim bid MO_F32_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cosf") [dst] [src]-genSimplePrim bid MO_F32_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tanf") [dst] [src]-genSimplePrim bid MO_F32_Exp           [dst]   [src]          = genLibCCall bid (fsLit "expf") [dst] [src]-genSimplePrim bid MO_F32_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1f") [dst] [src]-genSimplePrim bid MO_F32_Log           [dst]   [src]          = genLibCCall bid (fsLit "logf") [dst] [src]-genSimplePrim bid MO_F32_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1pf") [dst] [src]-genSimplePrim bid MO_F32_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asinf") [dst] [src]-genSimplePrim bid MO_F32_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acosf") [dst] [src]-genSimplePrim bid MO_F32_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atanf") [dst] [src]-genSimplePrim bid MO_F32_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinhf") [dst] [src]-genSimplePrim bid MO_F32_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "coshf") [dst] [src]-genSimplePrim bid MO_F32_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanhf") [dst] [src]-genSimplePrim bid MO_F32_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "powf")  [dst] [x,y]-genSimplePrim bid MO_F32_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinhf") [dst] [src]-genSimplePrim bid MO_F32_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acoshf") [dst] [src]-genSimplePrim bid MO_F32_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanhf") [dst] [src]-genSimplePrim bid MO_F64_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sin") [dst] [src]-genSimplePrim bid MO_F64_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cos") [dst] [src]-genSimplePrim bid MO_F64_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tan") [dst] [src]-genSimplePrim bid MO_F64_Exp           [dst]   [src]          = genLibCCall bid (fsLit "exp") [dst] [src]-genSimplePrim bid MO_F64_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1") [dst] [src]-genSimplePrim bid MO_F64_Log           [dst]   [src]          = genLibCCall bid (fsLit "log") [dst] [src]-genSimplePrim bid MO_F64_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1p") [dst] [src]-genSimplePrim bid MO_F64_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asin") [dst] [src]-genSimplePrim bid MO_F64_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acos") [dst] [src]-genSimplePrim bid MO_F64_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atan") [dst] [src]-genSimplePrim bid MO_F64_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinh") [dst] [src]-genSimplePrim bid MO_F64_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "cosh") [dst] [src]-genSimplePrim bid MO_F64_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanh") [dst] [src]-genSimplePrim bid MO_F64_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "pow")  [dst] [x,y]-genSimplePrim bid MO_F64_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinh") [dst] [src]-genSimplePrim bid MO_F64_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acosh") [dst] [src]-genSimplePrim bid MO_F64_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanh") [dst] [src]-genSimplePrim bid MO_SuspendThread     [tok]   [rs,i]         = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i]-genSimplePrim bid MO_ResumeThread      [rs]    [tok]          = genRTSCCall bid (fsLit "resumeThread") [rs] [tok]-genSimplePrim bid MO_I64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y]-genSimplePrim bid MO_I64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y]-genSimplePrim bid MO_W64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y]-genSimplePrim bid MO_W64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y]-genSimplePrim _   op                   dst     args           = do-  platform <- ncgPlatform <$> getConfig-  pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))--{- Note [Evaluate C-call arguments before placing in destination registers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When producing code for C calls we must take care when placing arguments-in their final registers. Specifically, we must ensure that temporary register-usage due to evaluation of one argument does not clobber a register in which we-already placed a previous argument (e.g. as the code generation logic for-MO_Shl can clobber %rcx due to x86 instruction limitations).--This is precisely what happened in #18527. Consider this C--:--    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));--Here we are calling the C function `doSomething` with three arguments, the last-involving a non-trivial expression involving MO_Shl. In this case the NCG could-naively generate the following assembly (where $tmp denotes some temporary-register and $argN denotes the register for argument N, as dictated by the-platform's calling convention):--    mov _s2hp, $arg1   # place first argument-    mov _s2hq, $arg2   # place second argument--    # Compute 1 << _s2hz-    mov _s2hz, %rcx-    shl %cl, $tmp--    # Compute (_s2hw | (1 << _s2hz))-    mov _s2hw, $arg3-    or $tmp, $arg3--    # Perform the call-    call func--This code is outright broken on Windows which assigns $arg1 to %rcx. This means-that the evaluation of the last argument clobbers the first argument.--To avoid this we use a rather awful hack: when producing code for a C call with-at least one non-trivial argument, we first evaluate all of the arguments into-local registers before moving them into their final calling-convention-defined-homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an-expression which might contain a MachOp since these are the only cases which-might clobber registers. Furthermore, we use a conservative approximation of-this condition (only looking at the top-level of CmmExprs) to avoid spending-too much effort trying to decide whether we want to take the fast path.--Note that this hack *also* applies to calls to out-of-line PrimTargets (which-are lowered via a C call), which will ultimately end up in-genForeignCall{32,64}.--}---- | See Note [Evaluate C-call arguments before placing in destination registers]-evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])-evalArgs bid actuals-  | any loadIntoRegMightClobberOtherReg actuals = do-      regs_blks <- mapM evalArg actuals-      return (concatOL $ map fst regs_blks, map snd regs_blks)-  | otherwise = return (nilOL, actuals)-  where--    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)-    evalArg actual = do-        platform <- getPlatform-        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)-        return (instrs, CmmReg $ CmmLocal lreg)--    newLocalReg :: CmmType -> NatM LocalReg-    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty---- | Might the code to put this expression into a register--- clobber any other registers?-loadIntoRegMightClobberOtherReg :: CmmExpr -> Bool-loadIntoRegMightClobberOtherReg (CmmReg _)      = False-loadIntoRegMightClobberOtherReg (CmmRegOff _ _) = False-loadIntoRegMightClobberOtherReg (CmmLit _)      = False-  -- NB: this last 'False' is slightly risky, because the code for loading-  -- a literal into a register is not entirely trivial.-loadIntoRegMightClobberOtherReg _               = True---- Note [DIV/IDIV for bytes]--- ~~~~~~~~~~~~~~~~~~~~~~~~~--- IDIV reminder:---   Size    Dividend   Divisor   Quotient    Remainder---   byte    %ax         r/m8      %al          %ah---   word    %dx:%ax     r/m16     %ax          %dx---   dword   %edx:%eax   r/m32     %eax         %edx---   qword   %rdx:%rax   r/m64     %rax         %rdx------ We do a special case for the byte division because the current--- codegen doesn't deal well with accessing %ah register (also,--- accessing %ah in 64-bit mode is complicated because it cannot be an--- operand of many instructions). So we just widen operands to 16 bits--- and get the results from %al, %dl. This is not optimal, but a few--- register moves are probably not a huge deal when doing division.----- | Generate C call to the given function in ghc-prim-genPrimCCall-  :: BlockId-  -> FastString-  -> [CmmFormal]-  -> [CmmActual]-  -> NatM InstrBlock-genPrimCCall bid lbl_txt dsts args = do-  config <- getConfig-  -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel-  let lbl = mkCmmCodeLabel primUnitId lbl_txt-  addr <- cmmMakeDynamicReference config CallReference lbl-  let conv = ForeignConvention CCallConv [] [] CmmMayReturn-  genCCall bid addr conv dsts args---- | Generate C call to the given function in libc-genLibCCall-  :: BlockId-  -> FastString-  -> [CmmFormal]-  -> [CmmActual]-  -> NatM InstrBlock-genLibCCall bid lbl_txt dsts args = do-  config <- getConfig-  -- Assume we can call these functions directly, and that they're not in a dynamic library.-  -- TODO: Why is this ok? Under linux this code will be in libm.so-  --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31-  let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction-  addr <- cmmMakeDynamicReference config CallReference lbl-  let conv = ForeignConvention CCallConv [] [] CmmMayReturn-  genCCall bid addr conv dsts args---- | Generate C call to the given function in the RTS-genRTSCCall-  :: BlockId-  -> FastString-  -> [CmmFormal]-  -> [CmmActual]-  -> NatM InstrBlock-genRTSCCall bid lbl_txt dsts args = do-  config <- getConfig-  -- Assume we can call these functions directly, and that they're not in a dynamic library.-  let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction-  addr <- cmmMakeDynamicReference config CallReference lbl-  let conv = ForeignConvention CCallConv [] [] CmmMayReturn-  genCCall bid addr conv dsts args---- | Generate a real C call to the given address with the given convention-genCCall-  :: BlockId-  -> CmmExpr-  -> ForeignConvention-  -> [CmmFormal]-  -> [CmmActual]-  -> NatM InstrBlock-genCCall bid addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do-  platform <- getPlatform-  is32Bit <- is32BitPlatform-  let args_hints = zip args (argHints ++ repeat NoHint)-      prom_args = map (maybePromoteCArgToW32 platform) args_hints-  (instrs0, args') <- evalArgs bid prom_args-  instrs1 <- if is32Bit-    then genCCall32 addr conv dest_regs args'-    else genCCall64 addr conv dest_regs args'-  return (instrs0 `appOL` instrs1)--maybePromoteCArgToW32 :: Platform -> (CmmExpr, ForeignHint) -> CmmExpr-maybePromoteCArgToW32 platform (arg, hint)- | wfrom < wto =-    -- As wto=W32, we only need to handle integer conversions,-    -- never Float -> Double.-    case hint of-      SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg]-      _          -> CmmMachOp (MO_UU_Conv wfrom wto) [arg]- | otherwise   = arg- where-   ty = cmmExprType platform arg-   wfrom = typeWidth ty-   wto = W32--genCCall32 :: CmmExpr           -- ^ address of the function to call-           -> ForeignConvention -- ^ calling convention-           -> [CmmFormal]       -- ^ where to put the result-           -> [CmmActual]       -- ^ arguments (of mixed type)-           -> NatM InstrBlock-genCCall32 addr _conv dest_regs args = do-        config <- getConfig-        let platform = ncgPlatform config--            -- If the size is smaller than the word, we widen things (see maybePromoteCArg)-            arg_size_bytes :: CmmType -> Int-            arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))--            roundTo a x | x `mod` a == 0 = x-                        | otherwise = x + a - (x `mod` a)--            push_arg :: CmmActual {-current argument-}-                            -> NatM InstrBlock  -- code--            push_arg  arg -- we don't need the hints on x86-              | isWord64 arg_ty = do-                RegCode64 code r_hi r_lo <- iselExpr64 arg-                delta <- getDeltaNat-                setDeltaNat (delta - 8)-                return (       code `appOL`-                               toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),-                                     PUSH II32 (OpReg r_lo), DELTA (delta - 8),-                                     DELTA (delta-8)]-                    )--              | isFloatType arg_ty || isVecType arg_ty = do-                (reg, code) <- getSomeReg arg-                delta <- getDeltaNat-                setDeltaNat (delta-size)-                return (code `appOL`-                                toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),-                                      DELTA (delta-size),-                                      let addr = AddrBaseIndex (EABaseReg esp)-                                                                EAIndexNone-                                                                (ImmInt 0)-                                          format = cmmTypeFormat arg_ty-                                      in--                                       movInstr config format (OpReg reg) (OpAddr addr)--                                     ]-                               )--              | otherwise = do-                -- Arguments can be smaller than 32-bit, but we still use @PUSH-                -- II32@ - the usual calling conventions expect integers to be-                -- 4-byte aligned.-                massert ((typeWidth arg_ty) <= W32)-                (operand, code) <- getOperand arg-                delta <- getDeltaNat-                setDeltaNat (delta-size)-                return (code `snocOL`-                        PUSH II32 operand `snocOL`-                        DELTA (delta-size))--              where-                 arg_ty = cmmExprType platform arg-                 size = arg_size_bytes arg_ty -- Byte size--        let-            -- Align stack to 16n for calls, assuming a starting stack-            -- alignment of 16n - word_size on procedure entry. Which we-            -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c.-            sizes               = map (arg_size_bytes . cmmExprType platform) (reverse args)-            raw_arg_size        = sum sizes + platformWordSizeInBytes platform-            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size-            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform---        delta0 <- getDeltaNat-        setDeltaNat (delta0 - arg_pad_size)--        push_codes <- mapM push_arg (reverse args)-        delta <- getDeltaNat-        massert (delta == delta0 - tot_arg_size)--        -- deal with static vs dynamic call targets-        callinsns <--          case addr of-            CmmLit (CmmLabel lbl)-               -> return $ unitOL (CALL (Left fn_imm) [])-               where fn_imm = ImmCLbl lbl-            _-               -> do { (dyn_r, dyn_c) <- getSomeReg addr-                     ; massert (isWord32 (cmmExprType platform addr))-                     ; return $ dyn_c `snocOL` CALL (Right dyn_r) [] }-        let push_code-                | arg_pad_size /= 0-                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),-                        DELTA (delta0 - arg_pad_size)]-                  `appOL` concatOL push_codes-                | otherwise-                = concatOL push_codes--            call = callinsns `appOL`-                   toOL (-                      (if tot_arg_size == 0 then [] else-                       [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)])-                      ++-                      [DELTA delta0]-                   )-        setDeltaNat delta0--        let-            -- assign the results, if necessary-            assign_code []     = nilOL-            assign_code [dest]-              | isVecType ty-              = unitOL (mkRegRegMoveInstr config (cmmTypeFormat ty) xmm0 r_dest)-              | isFloatType ty =-                  -- we assume SSE2-                  let tmp_amode = AddrBaseIndex (EABaseReg esp)-                                                       EAIndexNone-                                                       (ImmInt 0)-                      fmt = floatFormat w-                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),-                                   DELTA (delta0 - b),-                                   X87Store fmt  tmp_amode,-                                   -- X87Store only supported for the CDECL ABI-                                   -- NB: This code will need to be-                                   -- revisited once GHC does more work around-                                   -- SIGFPE f-                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),-                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),-                                   DELTA delta0]-              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),-                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]-              | otherwise      = unitOL (MOV (intFormat w)-                                             (OpReg eax)-                                             (OpReg r_dest))-              where-                    ty = localRegType dest-                    w  = typeWidth ty-                    b  = widthInBytes w-                    r_dest_hi = getHiVRegFromLo r_dest-                    r_dest    = getLocalRegReg dest-            assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many)--        return (push_code `appOL`-                call `appOL`-                assign_code dest_regs)--genCCall64 :: CmmExpr           -- ^ address of function to call-           -> ForeignConvention -- ^ calling convention-           -> [CmmFormal]       -- ^ where to put the result-           -> [CmmActual]       -- ^ arguments (of mixed type)-           -> NatM InstrBlock-genCCall64 addr conv dest_regs args = do-    config <- getConfig-    let platform = ncgPlatform config-        word_size = platformWordSizeInBytes platform-        wordFmt = archWordFormat (target32Bit platform)--    -- Compute the code for loading arguments into registers,-    -- returning the leftover arguments that will need to be passed on the stack.-    ---    -- NB: the code for loading references to data into registers is computed-    -- later (in 'pushArgs'), because we don't yet know where the data will be-    -- placed (due to alignment requirements).-    LoadArgs-      { stackArgs       = proper_stack_args-      , stackDataArgs   = stack_data_args-      , usedRegs        = arg_regs_used-      , assignArgsCode  = assign_args_code-      }-      <- loadArgs config args--    let--    -- Pad all arguments and data passed on stack to align them properly.-        (stk_args_with_padding, args_aligned_16) =-          padStackArgs platform (proper_stack_args, stack_data_args)--    -- Align stack to 16n for calls, assuming a starting stack-    -- alignment of 16n - word_size on procedure entry. Which we-    -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c-        need_realign_call = args_aligned_16-    align_call_code <--      if need_realign_call-      then addStackPadding word_size-      else return nilOL--    -- Compute the code that pushes data to the stack, and also-    -- the code that loads references to that data into registers,-    -- when the data is passed by reference in a register.-    (load_data_refs, push_code) <--      pushArgs config proper_stack_args stk_args_with_padding--    -- On Windows, leave stack space for the arguments that we are passing-    -- in registers (the so-called shadow space).-    let shadow_space =-          if platformOS platform == OSMinGW32-          then 8 * length (allArgRegs platform)-            -- NB: the shadow store is always 8 * 4 = 32 bytes large,-            -- i.e. the cumulative size of rcx, rdx, r8, r9 (see 'allArgRegs').-          else 0-    shadow_space_code <- addStackPadding shadow_space--    let total_args_size-          = shadow_space-          + sum (map (stackArgSpace platform) stk_args_with_padding)-        real_size =-          total_args_size + if need_realign_call then word_size else 0--    -- End of argument passing.-    ---    -- Next step: emit the appropriate call instruction.-    delta <- getDeltaNat--    let -- The System V AMD64 ABI requires us to set %al to the number of SSE2-        -- registers that contain arguments, if the called routine-        -- is a varargs function.  We don't know whether it's a-        -- varargs function or not, so we have to assume it is.-        ---        -- It's not safe to omit this assignment, even if the number-        -- of SSE2 regs in use is zero.  If %al is larger than 8-        -- on entry to a varargs function, seg faults ensue.-        nb_sse_regs_used = count (isFloatFormat . regWithFormat_format) arg_regs_used-        assign_eax_sse_regs-          = unitOL (MOV II32 (OpImm (ImmInt nb_sse_regs_used)) (OpReg eax))-          -- Note: we do this on Windows as well. It's not entirely clear why-          -- it's needed (the Windows X86_64 calling convention does not-          -- dictate it), but we get segfaults without it.-          ---          -- One test case exhibiting the issue is T20030_test1j;-          -- if you change this, make sure to run it in a loop for a while-          -- with at least -j8 to check.--        -- Live registers we are annotating the call instruction with-        arg_regs = [RegWithFormat eax wordFmt] ++ arg_regs_used--    -- deal with static vs dynamic call targets-    (callinsns,_cconv) <- case addr of-      CmmLit (CmmLabel lbl) ->-        return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv)-      _ -> do-        (dyn_r, dyn_c) <- getSomeReg addr-        return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)--    let call = callinsns `appOL`-               toOL (-                    -- Deallocate parameters after call for ccall-                  (if real_size==0 then [] else-                   [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])-                  ++-                  [DELTA (delta + real_size)]-               )-    setDeltaNat (delta + real_size)--    let-        -- assign the results, if necessary-        assign_code []     = nilOL-        assign_code [dest] =-          unitOL $-            mkRegRegMoveInstr config fmt reg r_dest-          where-            reg = if isIntFormat fmt then rax else xmm0-            fmt = cmmTypeFormat rep-            rep = localRegType dest-            r_dest = getRegisterReg platform (CmmLocal dest)-        assign_code _many = panic "genForeignCall.assign_code many"--    return (align_call_code     `appOL`-            push_code           `appOL`-            assign_args_code    `appOL`-            load_data_refs      `appOL`-            shadow_space_code   `appOL`-            assign_eax_sse_regs `appOL`-            call                `appOL`-            assign_code dest_regs)---- -------------------------------------------------------------------------------- Loading arguments into registers for 64-bit C calls.---- | Information needed to know how to pass arguments in a C call,--- and in particular how to load them into registers.-data LoadArgs-  = LoadArgs-  -- | Arguments that should be passed on the stack-  { stackArgs     :: [RawStackArg]-  -- | Additional values to store onto the stack.-  , stackDataArgs :: [CmmExpr]-  -- | Which registers are we using for argument passing?-  , usedRegs      :: [RegWithFormat]-  -- | The code to assign arguments to registers used for argument passing.-  , assignArgsCode :: InstrBlock-  }-instance Semigroup LoadArgs where-  LoadArgs a1 d1 r1 j1 <> LoadArgs a2 d2 r2 j2-    = LoadArgs (a1 ++ a2) (d1 ++ d2) (r1 ++ r2) (j1 S.<> j2)-instance Monoid LoadArgs where-  mempty = LoadArgs [] [] [] nilOL---- | An argument passed on the stack, either directly or by reference.------ The padding information hasn't yet been computed (see 'StackArg').-data RawStackArg-  -- | Pass the argument on the stack directly.-  = RawStackArg { stackArgExpr :: CmmExpr }-  -- | Pass the argument by reference.-  | RawStackArgRef-    { stackRef :: StackRef-       -- ^ is the reference passed in a register, or on the stack?-    , stackRefArgSize :: Int-        -- ^ the size of the data pointed to-    }-  deriving ( Show )---- | An argument passed on the stack, either directly or by reference,--- with additional padding information.-data StackArg-  -- | Pass the argument on the stack directly.-  = StackArg-      { stackArgExpr :: CmmExpr-      , stackArgPadding :: Int-        -- ^ padding required (in bytes)-      }-  -- | Pass the argument by reference.-  | StackArgRef-     { stackRef :: StackRef-        -- ^ where the reference is passed-     , stackRefArgSize :: Int-        -- ^ the size of the data pointed to-     , stackRefArgPadding :: Int-       -- ^ padding of the data pointed to-       -- (the reference itself never requires padding)-     }-  deriving ( Show )---- | Where is a reference to data on the stack passed?-data StackRef-  -- | In a register.-  = InReg Reg-  -- | On the stack.-  | OnStack-  deriving ( Eq, Ord, Show )--newtype Padding = Padding { paddingBytes :: Int }-  deriving ( Show, Eq, Ord )---- | How much space does this 'StackArg' take up on the stack?------ Only counts the "reference" part for references, not the data it points to.-stackArgSpace :: Platform -> StackArg -> Int-stackArgSpace platform = \case-  StackArg arg padding ->-    argSize platform arg + padding-  StackArgRef { stackRef = ref } ->-    case ref of-      InReg   {} -> 0-      OnStack {} -> 8---- | Pad arguments, assuming we start aligned to a 16-byte boundary.------ Returns padded arguments, together with whether we end up aligned--- to a 16-byte boundary.-padStackArgs :: Platform-             -> ([RawStackArg], [CmmExpr])-             -> ([StackArg], Bool)-padStackArgs platform (args0, data_args0) =-  let-    -- Pad the direct args-    (args, align_16_mid) = pad_args True args0--    -- Pad the data section-    (data_args, align_16_end) = pad_args align_16_mid (map RawStackArg data_args0)--    -- Now figure out where the data is placed relative to the direct arguments,-    -- in order to resolve references.-    resolve_args :: [(RawStackArg, Padding)] -> [Padding] -> [StackArg]-    resolve_args [] _ = []-    resolve_args ((stk_arg, Padding pad):rest) pads =-      let (this_arg, pads') =-            case stk_arg of-              RawStackArg arg -> (StackArg arg pad, pads)-              RawStackArgRef ref size ->-                let (Padding arg_pad : rest_pads) = pads-                    arg =-                      StackArgRef-                        { stackRef = ref-                        , stackRefArgSize = size-                        , stackRefArgPadding = arg_pad }-                in (arg, rest_pads)-      in this_arg : resolve_args rest pads'--  in-    ( resolve_args args (fmap snd data_args) ++-        [ case data_arg of-            RawStackArg arg -> StackArg arg pad-            RawStackArgRef {} -> panic "padStackArgs: reference in data section"-        | (data_arg, Padding pad) <- data_args-        ]-    , align_16_end )--  where-    pad_args :: Bool -> [RawStackArg] -> ([(RawStackArg, Padding)], Bool)-    pad_args aligned_16 [] = ([], aligned_16)-    pad_args aligned_16 (arg:args)-      | needed_alignment > 16-      -- We don't know if the stack is aligned to 8 (mod 32) or 24 (mod 32).-      -- This makes aligning the stack to a 32 or 64 byte boundary more-      -- complicated, in particular with DELTA.-      = sorry $ unlines-        [ "X86_86 C call: unsupported argument."-        , "  Alignment requirement: " ++ show needed_alignment ++ " bytes."-        , if platformOS platform == OSMinGW32-          then "  The X86_64 NCG does not (yet) support Windows C calls with 256/512 bit vectors."-          else "  The X86_64 NCG cannot (yet) pass 256/512 bit vectors on the stack for C calls."-        , "  Please use the LLVM backend (-fllvm)." ]-      | otherwise-      = let ( rest, final_align_16 ) = pad_args next_aligned_16 args-        in  ( (arg, Padding padding) : rest, final_align_16 )--      where-        needed_alignment = case arg of-          RawStackArg arg   -> argSize platform arg-          RawStackArgRef {} -> platformWordSizeInBytes platform-        padding-          | needed_alignment < 16 || aligned_16-          = 0-          | otherwise-          = 8-        next_aligned_16 = not ( aligned_16 && needed_alignment < 16 )---- | Load arguments into available registers.-loadArgs :: NCGConfig -> [CmmExpr] -> NatM LoadArgs-loadArgs config args-  | platformOS platform == OSMinGW32-  = evalStateT (loadArgsWin config args) (allArgRegs platform)-  | otherwise-  = evalStateT (loadArgsSysV config args) (allIntArgRegs platform-                                          ,allFPArgRegs  platform)-  where-    platform = ncgPlatform config---- | Load arguments into available registers (System V AMD64 ABI).-loadArgsSysV :: NCGConfig-             -> [CmmExpr]-             -> StateT ([Reg], [Reg]) NatM LoadArgs-loadArgsSysV _ [] = return mempty-loadArgsSysV config (arg:rest) = do-  (iregs, fregs) <- get-  -- No available registers: pass everything on the stack (shortcut).-  if null iregs && null fregs-  then return $-          LoadArgs-            { stackArgs       = map RawStackArg (arg:rest)-            , stackDataArgs   = []-            , assignArgsCode  = nilOL-            , usedRegs        = []-            }-  else do-    mbReg <--      if-        | isIntFormat arg_fmt-        , ireg:iregs' <- iregs-        -> do put (iregs', fregs)-              return $ Just ireg-        | isFloatFormat arg_fmt || isVecFormat arg_fmt-        , freg:fregs' <- fregs-        -> do put (iregs, fregs')-              return $ Just freg-        | otherwise-        -> return Nothing-    this_arg <--      case mbReg of-        Just reg -> do-          assign_code <- lift $ loadArgIntoReg arg reg-          return $-            LoadArgs-                { stackArgs       = [] -- passed in register-                , stackDataArgs   = []-                , assignArgsCode  = assign_code-                , usedRegs        = [RegWithFormat reg arg_fmt]-                }-        Nothing -> do-          return $-            -- No available register for this argument: pass it on the stack.-            LoadArgs-                { stackArgs       = [RawStackArg arg]-                , stackDataArgs   = []-                , assignArgsCode  = nilOL-                , usedRegs        = []-                }-    others <- loadArgsSysV config rest-    return $ this_arg S.<> others--  where-    platform = ncgPlatform config-    arg_fmt = cmmTypeFormat (cmmExprType platform arg)---- | Compute all things that will need to be pushed to the stack.------ On Windows, an argument passed by reference will require two pieces of data:------  - the reference (returned in the first position)---  - the actual data (returned in the second position)-computeWinPushArgs :: Platform -> [CmmExpr] -> ([RawStackArg], [CmmExpr])-computeWinPushArgs platform = go-  where-    go :: [CmmExpr] -> ([RawStackArg], [CmmExpr])-    go [] = ([], [])-    go (arg:args) =-      let-        arg_size = argSize platform arg-        (this_arg, add_this_arg)-          | arg_size > 8-          = ( RawStackArgRef OnStack arg_size, (arg :) )-          | otherwise-          = ( RawStackArg arg, id )-        (stk_args, stk_data) = go args-      in-        (this_arg:stk_args, add_this_arg stk_data)---- | Load arguments into available registers (Windows C X64 calling convention).-loadArgsWin :: NCGConfig -> [CmmExpr] -> StateT [(Reg,Reg)] NatM LoadArgs-loadArgsWin _ [] = return mempty-loadArgsWin config (arg:rest) = do-  regs <- get-  case regs of-    reg:regs' -> do-      put regs'-      this_arg <- lift $ load_arg_win reg-      rest <- loadArgsWin config rest-      return $ this_arg S.<> rest-    [] -> do-      -- No more registers available: pass all (remaining) arguments on the stack.-      let (stk_args, data_args) = computeWinPushArgs platform (arg:rest)-      return $-        LoadArgs-          { stackArgs       = stk_args-          , stackDataArgs   = data_args-          , assignArgsCode  = nilOL-          , usedRegs        = []-          }-  where-    platform = ncgPlatform config-    arg_fmt = cmmTypeFormat $ cmmExprType platform arg-    load_arg_win (ireg, freg)-      | isVecFormat arg_fmt-       -- Vectors are passed by reference.-       -- See Note [The Windows X64 C calling convention].-      = do return $-             LoadArgs-                -- Pass the reference in a register,-                -- and the argument data on the stack.-                { stackArgs       = [RawStackArgRef (InReg ireg) (argSize platform arg)]-                , stackDataArgs   = [arg] -- we don't yet know where the data will reside,-                , assignArgsCode  = nilOL -- so we defer computing the reference and storing it-                                          -- in the register until later-                , usedRegs        = [RegWithFormat ireg II64]-                }-      | otherwise-      = do let arg_reg-                  | isFloatFormat arg_fmt-                  = freg-                  | otherwise-                  = ireg-           assign_code <- loadArgIntoReg arg arg_reg-           -- Recall that, for varargs, we must pass floating-point-           -- arguments in both fp and integer registers.-           let (assign_code', regs')-                | isFloatFormat arg_fmt =-                    ( assign_code `snocOL` MOVD FF64 II64 (OpReg freg) (OpReg ireg),-                      [ RegWithFormat freg FF64-                      , RegWithFormat ireg II64 ])-                | otherwise = (assign_code, [RegWithFormat ireg II64])-           return $-             LoadArgs-               { stackArgs       = [] -- passed in register-               , stackDataArgs   = []-               , assignArgsCode = assign_code'-               , usedRegs = regs'-               }---- | Load an argument into a register.------ Assumes that the expression does not contain any MachOps,--- as per Note [Evaluate C-call arguments before placing in destination registers].-loadArgIntoReg :: CmmExpr -> Reg -> NatM InstrBlock-loadArgIntoReg arg reg = do-  when (debugIsOn && loadIntoRegMightClobberOtherReg arg) $ do-    platform <- getPlatform-    massertPpr False $-      vcat [ text "loadArgIntoReg: arg might contain MachOp"-           , text "arg:" <+> pdoc platform arg ]-  arg_code <- getAnyReg arg-  return $ arg_code reg---- -------------------------------------------------------------------------------- Pushing arguments onto the stack for 64-bit C calls.---- | The size of an argument (in bytes).------ Never smaller than the platform word width.-argSize :: Platform -> CmmExpr -> Int-argSize platform arg =-  max (platformWordSizeInBytes platform) $-    widthInBytes (typeWidth $ cmmExprType platform arg)---- | Add the given amount of padding on the stack.-addStackPadding :: Int -- ^ padding (in bytes)-                -> NatM InstrBlock-addStackPadding pad_bytes-  | pad_bytes == 0-  = return nilOL-  | otherwise-  = do delta <- getDeltaNat-       setDeltaNat (delta - pad_bytes)-       return $-         toOL [ SUB II64 (OpImm (ImmInt pad_bytes)) (OpReg rsp)-              , DELTA (delta - pad_bytes)-              ]---- | Push one argument directly to the stack (by value).------ Assumes the current stack pointer fulfills any necessary alignment requirements.-pushArgByValue :: NCGConfig -> CmmExpr -> NatM InstrBlock-pushArgByValue config arg-   -- For 64-bit integer arguments, use PUSH II64.-   ---   -- Note: we *must not* do this for smaller arguments.-   -- For example, if we tried to push an argument such as @CmmLoad addr W32 aln@,-   -- we could end up reading unmapped memory and segfaulting.-   | isIntFormat fmt-   , formatInBytes fmt == 8-   = do-     (arg_op, arg_code) <- getOperand arg-     delta <- getDeltaNat-     setDeltaNat (delta-arg_size)-     return $-       arg_code `appOL` toOL-       [ PUSH II64 arg_op-       , DELTA (delta-arg_size) ]--   | otherwise-   = do-     (arg_reg, arg_code) <- getSomeReg arg-     delta <- getDeltaNat-     setDeltaNat (delta-arg_size)-     return $ arg_code `appOL` toOL-        [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp)-        , DELTA (delta-arg_size)-        , movInstr config fmt (OpReg arg_reg) (OpAddr (spRel platform 0)) ]--    where-      platform = ncgPlatform config-      arg_size = argSize platform arg-      arg_rep = cmmExprType platform arg-      fmt = cmmTypeFormat arg_rep---- | Load an argument into a register or push it to the stack.-loadOrPushArg :: NCGConfig -> (StackArg, Maybe Int) -> NatM (InstrBlock, InstrBlock)-loadOrPushArg config (stk_arg, mb_off) =-  case stk_arg of-    StackArg arg pad -> do-      push_code <- pushArgByValue config arg-      pad_code  <- addStackPadding pad-      return (nilOL, push_code `appOL` pad_code)-    StackArgRef { stackRef = ref } ->-      case ref of-        -- Pass the reference in a register-        InReg ireg ->-          return (unitOL $ LEA II64 (OpAddr (spRel platform off)) (OpReg ireg), nilOL)-        -- Pass the reference on the stack-        OnStack {} -> do-          tmp <- getNewRegNat II64-          delta <- getDeltaNat-          setDeltaNat (delta-arg_ref_size)-          let push_code = toOL-                [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_ref_size)) (OpReg rsp)-                , DELTA (delta-arg_ref_size)-                , LEA II64 (OpAddr (spRel platform off)) (OpReg tmp)-                , MOV II64 (OpReg tmp) (OpAddr (spRel platform 0)) ]-          return (nilOL, push_code)-      where off = expectJust "push_arg_win offset" mb_off-    where-      arg_ref_size = 8 -- passing a reference to the argument-      platform = ncgPlatform config---- | Push arguments to the stack, right to left.------ On Windows, some arguments may need to be passed by reference,--- which requires separately passing the data and the reference.--- See Note [The Windows X64 C calling convention].-pushArgs :: NCGConfig-         -> [RawStackArg]-            -- ^ arguments proper (i.e. don't include the data for arguments passed by reference)-         -> [StackArg]-            -- ^ arguments we are passing on the stack-         -> NatM (InstrBlock, InstrBlock)-pushArgs config proper_args all_stk_args-  = do { let-            vec_offs :: [Maybe Int]-            vec_offs-              | platformOS platform == OSMinGW32-              = go stack_arg_size all_stk_args-              | otherwise-              = repeat Nothing--    ----------------------    -- Windows-only code--            -- Size of the arguments we are passing on the stack, counting only-            -- the reference part for arguments passed by reference.-            stack_arg_size = 8 * count not_in_reg proper_args-            not_in_reg (RawStackArg {}) = True-            not_in_reg (RawStackArgRef { stackRef = ref }) =-              case ref of-                InReg {} -> False-                OnStack {} -> True--            -- Check an offset is valid (8-byte aligned), for assertions.-            ok off = off `rem` 8 == 0--            -- Tricky code: compute the stack offset to the vector data-            -- for this argument.-            ---            -- If you're confused, Note [The Windows X64 C calling convention]-            -- contains a helpful diagram.-            go :: Int -> [StackArg] -> [Maybe Int]-            go _ [] = []-            go off (stk_arg:args) =-              assertPpr (ok off) (text "unaligned offset:" <+> ppr off) $-              case stk_arg of-                StackArg {} ->-                  -- Only account for the stack pointer movement.-                  let off' = off - stackArgSpace platform stk_arg-                  in Nothing : go off' args-                StackArgRef-                  { stackRefArgSize    = data_size-                  , stackRefArgPadding = data_pad } ->-                  assertPpr (ok data_size) (text "unaligned data size:" <+> ppr data_size) $-                  assertPpr (ok data_pad) (text "unaligned data padding:" <+> ppr data_pad) $-                  let off' = off-                        -- Next piece of data is after the data for this reference-                           + data_size + data_pad-                        -- ... and account for the stack pointer movement.-                           - stackArgSpace platform stk_arg-                  in Just (data_pad + off) : go off' args--    -- end of Windows-only code-    ------------------------------         -- Push the stack arguments (right to left),-         -- including both the reference and the data for arguments passed by reference.-       ; (load_regs, push_args) <- foldMapM (loadOrPushArg config) (reverse $ zip all_stk_args vec_offs)-       ; return (load_regs, push_args) }-  where-    platform = ncgPlatform config--{- Note [The Windows X64 C calling convention]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here are a few facts about the Windows X64 C calling convention that-are important:--  - any argument larger than 8 bytes must be passed by reference,-    and arguments smaller than 8 bytes are padded to 8 bytes.--  - the first four arguments are passed in registers:-      - floating-point scalar arguments are passed in %xmm0, %xmm1, %xmm2, %xmm3-      - other arguments are passed in %rcx, %rdx, %r8, %r9-        (this includes vector arguments, passed by reference)--    For variadic functions, it is additionally expected that floating point-    scalar arguments are copied to the corresponding integer register, e.g.-    the data in xmm2 should also be copied to r8.--    There is no requirement about setting %al like there is for the-    System V AMD64 ABI.--  - subsequent arguments are passed on the stack.--There are also alignment requirements:--  - the data for vectors must be aligned to the size of the vector,-    e.g. a 32 byte vector must be aligned on a 32 byte boundary,--  - the call instruction must be aligned to 16 bytes.-  (This differs from the System V AMD64 ABI, which mandates that the call-  instruction must be aligned to 32 bytes if there are any 32 byte vectors-  passed on the stack.)--This motivates our handling of vector values. Suppose we have a function call-with many arguments, several of them being vectors. We proceed as follows:-- - Add some padding, if necessary, to ensure the stack, when executing the call-    instruction, is 16-byte aligned. Whether this padding is necessary depends-    on what happens next. (Recall also that we start off at 8 (mod 16) alignment,-    as per Note [Stack Alignment on X86] in rts/StgCRun.c)-  - Push all the vectors to the stack first, adding padding after each one-    if necessary.-  - Then push the arguments:-      - for non-vectors, proceed as usual,-      - for vectors, push the address of the vector data we pushed above.-  - Then assign the registers:-      - for non-vectors, proceed as usual,-      - for vectors, store the address in a general-purpose register, as opposed-        to storing the data in an xmm register.--For a concrete example, suppose we have a call of the form:--  f x1 x2 x3 x4 x5 x6 x7--in which:--  - x2, x3, x5 and x7 are 16 byte vectors-  - the other arguments are all 8 byte wide--Now, x1, x2, x3, x4 will get passed in registers, except that we pass-x2 and x3 by reference, because they are vectors. We proceed as follows:--  - push the vectors to the stack: x7, x5, x3, x2 (in that order)-  - push the stack arguments in order: addr(x7), x6, addr(x5)-  - load the remaining arguments into registers: x4, addr(x3), addr(x2), x1--The tricky part is to get the right offsets for the addresses of the vector-data. The following visualisation will hopefully clear things up:--                                  ┌──┐-                                  │▓▓│ ─── padding to align the call instruction-                      ╭─╴         ╞══╡     (ensures Sp, below, is 16-byte aligned)-                      │           │  │-                      │  x7  ───╴ │  │-                      │           ├──┤-                      │           │  │-                      │  x5  ───╴ │  │-                      │           ├──┤-     vector data  ────┤           │  │-(individually padded) │  x3  ───╴ │  │-                      │           ├──┤-                      │           │  │-                      │  x2  ───╴ │  │-                      │           ├┄┄┤-                      │           │▓▓│ ─── padding to align x2 to 16 bytes-               ╭─╴    ╰─╴         ╞══╡-               │    addr(x7) ───╴ │  │    ╭─ from here: x7 is +64-               │                  ├──┤ ╾──╯    = 64 (position of x5)-     stack  ───┤         x6  ───╴ │  │         + 16 (size of x5) + 0 (padding of x7)-   arguments   │                  ├──┤         - 2 * 8 (x7 is 2 arguments higher than x5)-               │    addr(x5) ───╴ │  │-               ╰─╴            ╭─╴ ╞══╡ ╾─── from here:-                              │   │  │       - x2 is +32 = 24 (stack_arg_size) + 8 (padding of x2)-                   shadow  ───┤   │  │       - x3 is +48 = 32 (position of x2) + 16 (size of x2) + 0 (padding of x3)-                    space     │   │  │       - x5 is +64 = 48 (position of x3) + 16 (size of x3) + 0 (padding of x5)-                              │   │  │-                              ╰─╴ └──┘ ╾─── Sp--This is all tested in the simd013 test.--}---- -------------------------------------------------------------------------------- Generating a table-branch--{--Note [Sub-word subtlety during jump-table indexing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Offset the index by the start index of the jump table.-It's important that we do this *before* the widening below. To see-why, consider a switch with a sub-word, signed discriminant such as:--    switch [-5...+2] x::I16 {-        case -5: ...-        ...-        case +2: ...-    }--Consider what happens if we offset *after* widening in the case that-x=-4:--                                         // x == -4 == 0xfffc::I16-    indexWidened = UU_Conv(x);           // == 0xfffc::I64-    indexExpr    = indexWidened - (-5);  // == 0x10000::I64--This index is clearly nonsense given that the jump table only has-eight entries.--By contrast, if we widen *after* we offset then we get the correct-index (1),--                                         // x == -4 == 0xfffc::I16-    indexOffset  = x - (-5);             // == 1::I16-    indexExpr    = UU_Conv(indexOffset); // == 1::I64--See #21186.--}--genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock--genSwitch expr targets = do-  config <- getConfig-  let platform = ncgPlatform config-      expr_w = cmmExprWidth platform expr-      indexExpr0 = cmmOffset platform expr offset-      -- We widen to a native-width register because we cannot use arbitrary sizes-      -- in x86 addressing modes.-      -- See Note [Sub-word subtlety during jump-table indexing].-      indexExpr = CmmMachOp-        (MO_UU_Conv expr_w (platformWordWidth platform))-        [indexExpr0]-  if ncgPIC config-  then do-        (reg,e_code) <- getNonClobberedReg indexExpr-           -- getNonClobberedReg because it needs to survive across t_code-        lbl <- getNewLabelNat-        let is32bit = target32Bit platform-            os = platformOS platform-            -- Might want to use .rodata.<function we're in> instead, but as-            -- long as it's something unique it'll work out since the-            -- references to the jump table are in the appropriate section.-            rosection = case os of-              -- on Mac OS X/x86_64, put the jump table in the text section to-              -- work around a limitation of the linker.-              -- ld64 is unable to handle the relocations for-              --     .quad L1 - L0-              -- if L0 is not preceded by a non-anonymous label in its section.-              OSDarwin | not is32bit -> Section Text lbl-              _ -> Section ReadOnlyData lbl-        dynRef <- cmmMakeDynamicReference config DataReference lbl-        (tableReg,t_code) <- getSomeReg $ dynRef-        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)-                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))--        return $ e_code `appOL` t_code `appOL` toOL [-                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),-                                JMP_TBL (OpReg tableReg) ids rosection lbl-                       ]-  else do-        (reg,e_code) <- getSomeReg indexExpr-        lbl <- getNewLabelNat-        let is32bit = target32Bit platform-        if is32bit-          then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))-                   jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl-               in return $ e_code `appOL` unitOL jmp_code-          else do-            -- See Note [%rip-relative addressing on x86-64].-            tableReg <- getNewRegNat (intFormat (platformWordWidth platform))-            targetReg <- getNewRegNat (intFormat (platformWordWidth platform))-            let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))-                fmt = archWordFormat is32bit-                code = e_code `appOL` toOL-                    [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)-                    , MOV fmt op (OpReg targetReg)-                    , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl-                    ]-            return code-  where-    (offset, blockIds) = switchTargetsToTable targets-    ids = map (fmap DestBlockId) blockIds--generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)-generateJumpTableForInstr config (JMP_TBL _ ids section lbl)-    = let getBlockId (DestBlockId id) = id-          getBlockId _ = panic "Non-Label target in Jump Table"-          blockIds = map (fmap getBlockId) ids-      in Just (createJumpTable config blockIds section lbl)-generateJumpTableForInstr _ _ = Nothing--createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel-                -> GenCmmDecl (Alignment, RawCmmStatics) h g-createJumpTable config ids section lbl-    = let jumpTable-            | ncgPIC config =-                  let ww = ncgWordWidth config-                      jumpTableEntryRel Nothing-                          = CmmStaticLit (CmmInt 0 ww)-                      jumpTableEntryRel (Just blockid)-                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)-                          where blockLabel = blockLbl blockid-                  in map jumpTableEntryRel ids-            | otherwise = map (jumpTableEntry config) ids-      in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)--extractUnwindPoints :: [Instr] -> [UnwindPoint]-extractUnwindPoints instrs =-    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]---- -------------------------------------------------------------------------------- 'condIntReg' and 'condFltReg': condition codes into registers---- Turn those condition codes into integers now (when they appear on--- the right hand side of an assignment).------ (If applicable) Do not fill the delay slots here; you will confuse the--- register allocator.--condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register--condIntReg cond x y = do-  CondCode _ cond cond_code <- condIntCode cond x y-  tmp <- getNewRegNat II8-  let-        code dst = cond_code `appOL` toOL [-                    SETCC cond (OpReg tmp),-                    MOVZxL II8 (OpReg tmp) (OpReg dst)-                  ]-  return (Any II32 code)----- Note [SSE Parity Checks]--- ~~~~~~~~~~~~~~~~~~~~~~~~--- We have to worry about unordered operands (eg. comparisons--- against NaN).  If the operands are unordered, the comparison--- sets the parity flag, carry flag and zero flag.--- All comparisons are supposed to return false for unordered--- operands except for !=, which returns true.------ Optimisation: we don't have to test the parity flag if we--- know the test has already excluded the unordered case: eg >--- and >= test for a zero carry flag, which can only occur for--- ordered operands.------ By reversing comparisons we can avoid testing the parity--- for < and <= as well. If any of the arguments is an NaN we--- return false either way. If both arguments are valid then--- x <= y  <->  y >= x  holds. So it's safe to swap these.------ We invert the condition inside getRegister'and  getCondCode--- which should cover all invertable cases.--- All other functions translating FP comparisons to assembly--- use these to two generate the comparison code.------ As an example consider a simple check:------ func :: Float -> Float -> Int--- func x y = if x < y then 1 else 0------ Which in Cmm gives the floating point comparison.------  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;------ We used to compile this to an assembly code block like this:--- _c2gh:---  ucomiss %xmm2,%xmm1---  jp _c2gf---  jb _c2gg---  jmp _c2gf------ Where we have to introduce an explicit--- check for unordered results (using jmp parity):------ We can avoid this by exchanging the arguments and inverting the direction--- of the comparison. This results in the sequence of:------  ucomiss %xmm1,%xmm2---  ja _c2g2---  jmp _c2g1------ Removing the jump reduces the pressure on the branch prediction system--- and plays better with the uOP cache.--condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register-condFltReg is32Bit cond x y = condFltReg_sse2- where---  condFltReg_sse2 = do-    CondCode _ cond cond_code <- condFltCode cond x y-    tmp1 <- getNewRegNat (archWordFormat is32Bit)-    tmp2 <- getNewRegNat (archWordFormat is32Bit)-    let -- See Note [SSE Parity Checks]-        code dst =-           cond_code `appOL`-             (case cond of-                NE  -> or_unordered dst-                GU  -> plain_test   dst-                GEU -> plain_test   dst-                -- Use ASSERT so we don't break releases if these creep in.-                LTT -> assertPpr False (text "Should have been turned into >") $-                       and_ordered  dst-                LE  -> assertPpr False (text "Should have been turned into >=") $-                       and_ordered  dst-                _   -> and_ordered  dst)--        plain_test dst = toOL [-                    SETCC cond (OpReg tmp1),-                    MOVZxL II8 (OpReg tmp1) (OpReg dst)-                 ]-        or_unordered dst = toOL [-                    SETCC cond (OpReg tmp1),-                    SETCC PARITY (OpReg tmp2),-                    OR II8 (OpReg tmp1) (OpReg tmp2),-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)-                  ]-        and_ordered dst = toOL [-                    SETCC cond (OpReg tmp1),-                    SETCC NOTPARITY (OpReg tmp2),-                    AND II8 (OpReg tmp1) (OpReg tmp2),-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)-                  ]-    return (Any II32 code)----- -------------------------------------------------------------------------------- 'trivial*Code': deal with trivial instructions---- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.--- Only look for constants on the right hand side, because that's--- where the generic optimizer will have put them.---- Similarly, for unary instructions, we don't have to worry about--- matching an StInt as the argument, because genericOpt will already--- have handled the constant-folding.---{--The Rules of the Game are:--* You cannot assume anything about the destination register dst;-  it may be anything, including a fixed reg.--* You may compute an operand into a fixed reg, but you may not-  subsequently change the contents of that fixed reg.  If you-  want to do so, first copy the value either to a temporary-  or into dst.  You are free to modify dst even if it happens-  to be a fixed reg -- that's not your problem.--* You cannot assume that a fixed reg will stay live over an-  arbitrary computation.  The same applies to the dst reg.--* Temporary regs obtained from getNewRegNat are distinct from-  each other and from all other regs, and stay live over-  arbitrary computations.------------------------SDM's version of The Rules:--* If getRegister returns Any, that means it can generate correct-  code which places the result in any register, period.  Even if that-  register happens to be read during the computation.--  Corollary #1: this means that if you are generating code for an-  operation with two arbitrary operands, you cannot assign the result-  of the first operand into the destination register before computing-  the second operand.  The second operand might require the old value-  of the destination register.--  Corollary #2: A function might be able to generate more efficient-  code if it knows the destination register is a new temporary (and-  therefore not read by any of the sub-computations).--* If getRegister returns Any, then the code it generates may modify only:-        (a) fresh temporaries-        (b) the destination register-        (c) known registers (eg. %ecx is used by shifts)-  In particular, it may *not* modify global registers, unless the global-  register happens to be the destination register.--}--trivialCode :: Width -> (Operand -> Operand -> Instr)-            -> Maybe (Operand -> Operand -> Instr)-            -> CmmExpr -> CmmExpr -> NatM Register-trivialCode width instr m a b-    = do platform <- getPlatform-         trivialCode' platform width instr m a b--trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr)-             -> Maybe (Operand -> Operand -> Instr)-             -> CmmExpr -> CmmExpr -> NatM Register-trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b-  | is32BitLit platform lit_a = do-  b_code <- getAnyReg b-  let-       code dst-         = b_code dst `snocOL`-           revinstr (OpImm (litToImm lit_a)) (OpReg dst)-  return (Any (intFormat width) code)--trivialCode' _ width instr _ a b-  = genTrivialCode (intFormat width) instr a b---- This is re-used for floating pt instructions too.-genTrivialCode :: Format -> (Operand -> Operand -> Instr)-               -> CmmExpr -> CmmExpr -> NatM Register-genTrivialCode rep instr a b = do-  (b_op, b_code) <- getNonClobberedOperand b-  a_code <- getAnyReg a-  tmp <- getNewRegNat rep-  let-     -- We want the value of 'b' to stay alive across the computation of 'a'.-     -- But, we want to calculate 'a' straight into the destination register,-     -- because the instruction only has two operands (dst := dst `op` src).-     -- The troublesome case is when the result of 'b' is in the same register-     -- as the destination 'reg'.  In this case, we have to save 'b' in a-     -- new temporary across the computation of 'a'.-     code dst-        | dst `regClashesWithOp` b_op =-                b_code `appOL`-                unitOL (MOV rep b_op (OpReg tmp)) `appOL`-                a_code dst `snocOL`-                instr (OpReg tmp) (OpReg dst)-        | otherwise =-                b_code `appOL`-                a_code dst `snocOL`-                instr b_op (OpReg dst)-  return (Any rep code)--regClashesWithOp :: Reg -> Operand -> Bool-reg `regClashesWithOp` OpReg reg2   = reg == reg2-reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)-_   `regClashesWithOp` _            = False---- | Generate code for a fused multiply-add operation, of the form @± x * y ± z@,--- with 3 operands (FMA3 instruction set).-genFMA3Code :: Length-            -> Width-            -> FMASign-            -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register-genFMA3Code l w signs x y z = do-  config <- getConfig-  -- For the FMA instruction, we want to compute x * y + z-  ---  -- There are three possible instructions we could emit:-  ---  --   - fmadd213 z y x, result in x, z can be a memory address-  --   - fmadd132 x z y, result in y, x can be a memory address-  --   - fmadd231 y x z, result in z, y can be a memory address-  ---  -- This suggests two possible optimisations:-  ---  --   - OPTIMISATION 1-  --     If one argument is an address, use the instruction that allows-  --     a memory address in that position.-  ---  --   - OPTIMISATION 2-  --     If one argument is in a fixed register, use the instruction that puts-  --     the result in that same register.-  ---  -- Currently we follow neither of these optimisations,-  -- opting to always use fmadd213 for simplicity.-  ---  -- We would like to compute the result directly into the requested register.-  -- To do so we must first compute `x` into the destination register. This is-  -- only possible if the other arguments don't use the destination register.-  -- We check for this and if there is a conflict we move the result only after-  -- the computation. See #24496 how this went wrong in the past.-  let rep-        | l == 1-        = floatFormat w-        | otherwise-        = vecFormat (cmmVec l $ cmmFloat w)-  (y_reg, y_code) <- getNonClobberedReg y-  (z_op, z_code) <- getNonClobberedOperand z-  x_code <- getAnyReg x-  x_tmp <- getNewRegNat rep-  let-     fma213 = FMA3 rep signs FMA213--     code, code_direct, code_mov :: Reg -> InstrBlock-     -- Ideal: Compute the result directly into dst-     code_direct dst = x_code dst `snocOL`-                       fma213 z_op y_reg dst-     -- Fallback: Compute the result into a tmp reg and then move it.-     code_mov dst    = x_code x_tmp `snocOL`-                       fma213 z_op y_reg x_tmp `snocOL`-                       mkRegRegMoveInstr config rep x_tmp dst--     code dst =-        y_code `appOL`-        z_code `appOL`-        ( if arg_regs_conflict then code_mov dst else code_direct dst )--      where--        arg_regs_conflict =-          y_reg == dst ||-          case z_op of-            OpReg z_reg -> z_reg == dst-            OpAddr amode -> dst `elem` addrModeRegs amode-            OpImm {} -> False--  -- NB: Computing the result into a desired register using Any can be tricky.-  -- So for now, we keep it simple. (See #24496).-  return (Any rep code)---------------trivialUCode :: Format -> (Operand -> Instr)-             -> CmmExpr -> NatM Register-trivialUCode rep instr x = do-  x_code <- getAnyReg x-  let-     code dst =-        x_code dst `snocOL`-        instr (OpReg dst)-  return (Any rep code)----------------trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)-                  -> CmmExpr -> CmmExpr -> NatM Register-trivialFCode_sse2 ty instr x y-    = genTrivialCode format (instr format) x y-    where format = floatFormat ty------------------------------------------------------------------------------------coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register-coerceInt2FP from to x =  coerce_sse2- where--   coerce_sse2 = do-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand-     let-           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD-                             n -> panic $ "coerceInt2FP.sse: unhandled width ("-                                         ++ show n ++ ")"-           code dst = x_code `snocOL` opc (intFormat from) x_op dst-     return (Any (floatFormat to) code)-        -- works even if the destination rep is <II32-----------------------------------------------------------------------------------coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register-coerceFP2Int from to x =  coerceFP2Int_sse2- where-   coerceFP2Int_sse2 = do-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand-     let-           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;-                               n -> panic $ "coerceFP2Init.sse: unhandled width ("-                                           ++ show n ++ ")"-           code dst = x_code `snocOL` opc (intFormat to) x_op dst-     return (Any (intFormat to) code)-         -- works even if the destination rep is <II32------------------------------------------------------------------------------------coerceFP2FP :: Width -> CmmExpr -> NatM Register-coerceFP2FP to x = do-  (x_reg, x_code) <- getSomeReg x-  let-        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;-                                     n -> panic $ "coerceFP2FP: unhandled width ("-                                                 ++ show n ++ ")"-        code dst = x_code `snocOL` opc x_reg dst-  return (Any ( floatFormat to) code)------------------------------------------------------------------------------------sse2NegCode :: Width -> CmmExpr -> NatM Register-sse2NegCode w x = do-  let fmt = floatFormat w-  x_code <- getAnyReg x-  -- This is how gcc does it, so it can't be that bad:-  let-    const = case fmt of-      FF32 -> CmmInt 0x80000000 W32-      FF64 -> CmmInt 0x8000000000000000 W64-      x@II8  -> wrongFmt x-      x@II16 -> wrongFmt x-      x@II32 -> wrongFmt x-      x@II64 -> wrongFmt x-      x@(VecFormat {}) -> wrongFmt x--      where-        wrongFmt x = panic $ "sse2NegCode: " ++ show x-  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const-  tmp <- getNewRegNat fmt-  let-    code dst = x_code dst `appOL` amode_code `appOL` toOL [-        MOV fmt (OpAddr amode) (OpReg tmp),-        XOR fmt (OpReg tmp) (OpReg dst)-        ]-  ---  return (Any fmt code)--needLlvm :: MachOp -> NatM a-needLlvm mop =-  sorry $ unlines [ "Unsupported vector instruction for the native code generator:"-                  , show mop-                  , "Please use -fllvm." ]--incorrectOperands :: NatM a-incorrectOperands = sorry "Incorrect number of operands"--invalidConversion :: Width -> Width -> NatM a-invalidConversion from to =-  sorry $ "Invalid conversion operation from " ++ show from ++ " to " ++ show to---- | This works on the invariant that all jumps in the given blocks are required.---   Starting from there we try to make a few more jumps redundant by reordering---   them.---   We depend on the information in the CFG to do so so without a given CFG---   we do nothing.-invertCondBranches :: Maybe CFG  -- ^ CFG if present-                   -> LabelMap a -- ^ Blocks with info tables-                   -> [NatBasicBlock Instr] -- ^ List of basic blocks-                   -> [NatBasicBlock Instr]-invertCondBranches Nothing _       bs = bs-invertCondBranches (Just cfg) keep bs =-    invert bs-  where-    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]-    invert (BasicBlock lbl1 ins:b2@(BasicBlock lbl2 _):bs)-      | --pprTrace "Block" (ppr lbl1) True,-        Just (jmp1,jmp2) <- last2 ins-      , JXX cond1 target1 <- jmp1-      , target1 == lbl2-      --, pprTrace "CutChance" (ppr b1) True-      , JXX ALWAYS target2 <- jmp2-      -- We have enough information to check if we can perform the inversion-      -- TODO: We could also check for the last asm instruction which sets-      -- status flags instead. Which I suspect is worse in terms of compiler-      -- performance, but might be applicable to more cases-      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg-      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg-      -- Both jumps come from the same cmm statement-      , transitionSource edgeInfo1 == transitionSource edgeInfo2-      , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1--      --Int comparisons are invertable-      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch-      , Just _ <- maybeIntComparison op-      , Just invCond <- maybeInvertCond cond1--      --Swap the last two jumps, invert the conditional jumps condition.-      = let jumps =-              case () of-                -- We are free the eliminate the jmp. So we do so.-                _ | not (mapMember target1 keep)-                    -> [JXX invCond target2]-                -- If the conditional target is unlikely we put the other-                -- target at the front.-                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1-                    -> [JXX invCond target2, JXX ALWAYS target1]-                -- Keep things as-is otherwise-                  | otherwise-                    -> [jmp1, jmp2]-        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $-           (BasicBlock lbl1-            (dropTail 2 ins ++ jumps))-            : invert (b2:bs)-    invert (b:bs) = b : invert bs-    invert [] = []--genAtomicRMW-  :: BlockId-  -> Width-  -> AtomicMachOp-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM (InstrBlock, Maybe BlockId)-genAtomicRMW bid width amop dst addr n = do-    Amode amode addr_code <--        if amop `elem` [AMO_Add, AMO_Sub]-        then getAmode addr-        else getSimpleAmode addr  -- See genForeignCall for MO_Cmpxchg-    arg <- getNewRegNat format-    arg_code <- getAnyReg n-    platform <- ncgPlatform <$> getConfig--    let dst_r    = getRegisterReg platform  (CmmLocal dst)-    (code, lbl) <- op_code dst_r arg amode-    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)-  where-    -- Code for the operation-    op_code :: Reg       -- Destination reg-            -> Reg       -- Register containing argument-            -> AddrMode  -- Address of location to mutate-            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId-    op_code dst_r arg amode = do-        case amop of-          -- In the common case where dst_r is a virtual register the-          -- final move should go away, because it's the last use of arg-          -- and the first use of dst_r.-          AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))-                                     , MOV format (OpReg arg) (OpReg dst_r)-                                     ], bid)-          AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)-                                     , LOCK (XADD format (OpReg arg) (OpAddr amode))-                                     , MOV format (OpReg arg) (OpReg dst_r)-                                     ], bid)-          -- In these cases we need a new block id, and have to return it so-          -- that later instruction selection can reference it.-          AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)-          AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst-                                                      , NOT format dst-                                                      ])-          AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)-          AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)-      where-        -- Simulate operation that lacks a dedicated instruction using-        -- cmpxchg.-        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)-                     -> NatM (OrdList Instr, BlockId)-        cmpxchg_code instrs = do-            lbl1 <- getBlockIdNat-            lbl2 <- getBlockIdNat-            tmp <- getNewRegNat format--            --Record inserted blocks-            --  We turn A -> B into A -> A' -> A'' -> B-            --  with a self loop on A'.-            addImmediateSuccessorNat bid lbl1-            addImmediateSuccessorNat lbl1 lbl2-            updateCfgNat (addWeightEdge lbl1 lbl1 0)--            return $ (toOL-                [ MOV format (OpAddr amode) (OpReg eax)-                , JXX ALWAYS lbl1-                , NEWBLOCK lbl1-                  -- Keep old value so we can return it:-                , MOV format (OpReg eax) (OpReg dst_r)-                , MOV format (OpReg eax) (OpReg tmp)-                ]-                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL-                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))-                , JXX NE lbl1-                -- See Note [Introducing cfg edges inside basic blocks]-                -- why this basic block is required.-                , JXX ALWAYS lbl2-                , NEWBLOCK lbl2-                ],-                lbl2)-    format = intFormat width---- | Count trailing zeroes-genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)-genCtz bid width dst src = do-  is32Bit <- is32BitPlatform-  if is32Bit && width == W64-    then genCtz64_32 bid dst src-    else (,Nothing) <$> genCtzGeneric width dst src---- | Count trailing zeroes------ 64-bit width on 32-bit architecture-genCtz64_32-  :: BlockId-  -> LocalReg-  -> CmmExpr-  -> NatM (InstrBlock, Maybe BlockId)-genCtz64_32 bid dst src = do-  RegCode64 vcode rhi rlo <- iselExpr64 src-  let dst_r = getLocalRegReg dst-  lbl1 <- getBlockIdNat-  lbl2 <- getBlockIdNat-  tmp_r <- getNewRegNat II64--  -- New CFG Edges:-  --  bid -> lbl2-  --  bid -> lbl1 -> lbl2-  --  We also changes edges originating at bid to start at lbl2 instead.-  weights <- getCfgWeights-  updateCfgNat (addWeightEdge bid lbl1 110 .-                addWeightEdge lbl1 lbl2 110 .-                addImmediateSuccessor weights bid lbl2)--  -- The following instruction sequence corresponds to the pseudo-code-  ---  --  if (src) {-  --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);-  --  } else {-  --    dst = 64;-  --  }-  let instrs = vcode `appOL` toOL-           ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)-            , OR       II32 (OpReg rlo)         (OpReg tmp_r)-            , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)-            , JXX EQQ    lbl2-            , JXX ALWAYS lbl1--            , NEWBLOCK   lbl1-            , BSF     II32 (OpReg rhi)         dst_r-            , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)-            , BSF     II32 (OpReg rlo)         tmp_r-            , CMOV NE II32 (OpReg tmp_r)       dst_r-            , JXX ALWAYS lbl2--            , NEWBLOCK   lbl2-            ])-  return (instrs, Just lbl2)---- | Count trailing zeroes------ Generic case (width <= word size)-genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock-genCtzGeneric width dst src = do-  code_src <- getAnyReg src-  config <- getConfig-  let bw = widthInBits width-  let dst_r = getLocalRegReg dst-  if ncgBmiVersion config >= Just BMI2-  then do-      src_r <- getNewRegNat (intFormat width)-      let instrs = appOL (code_src src_r) $ case width of-              W8 -> toOL-                  [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)-                  , TZCNT II32 (OpReg src_r) dst_r-                  ]-              W16 -> toOL-                  [ TZCNT  II16 (OpReg src_r) dst_r-                  , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)-                  ]-              _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r-      return instrs-  else do-      -- The following insn sequence makes sure 'ctz 0' has a defined value.-      -- starting with Haswell, one could use the TZCNT insn instead.-      let format = if width == W8 then II16 else intFormat width-      src_r <- getNewRegNat format-      tmp_r <- getNewRegNat format-      let instrs = code_src src_r `appOL` toOL-               ([ MOVZxL  II8    (OpReg src_r)       (OpReg src_r) | width == W8 ] ++-                [ BSF     format (OpReg src_r)       tmp_r-                , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)-                , CMOV NE format (OpReg tmp_r)       dst_r-                ]) -- NB: We don't need to zero-extend the result for the-                   -- W8/W16 cases because the 'MOV' insn already-                   -- took care of implicitly clearing the upper bits-      return instrs------ | Copy memory------ Unroll memcpy calls if the number of bytes to copy isn't too large (cf--- ncgInlineThresholdMemcpy).  Otherwise, call C's memcpy.-genMemCpy-  :: BlockId-  -> Int-  -> CmmExpr-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genMemCpy bid align dst src arg_n = do--  let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n]--  case arg_n of-    CmmLit (CmmInt n _) -> do-      -- try to inline it-      mcode <- genMemCpyInlineMaybe align dst src n-      -- if it didn't inline, call the C function-      case mcode of-        Nothing -> libc_memcpy-        Just c  -> pure c--    -- not a literal size argument: call the C function-    _ -> libc_memcpy----genMemCpyInlineMaybe-  :: Int-  -> CmmExpr-  -> CmmExpr-  -> Integer-  -> NatM (Maybe InstrBlock)-genMemCpyInlineMaybe align dst src n = do-  config <- getConfig-  let-    platform     = ncgPlatform config-    maxAlignment = wordAlignment platform-                   -- only machine word wide MOVs are supported-    effectiveAlignment = min (alignmentOf align) maxAlignment-    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment---  -- The size of each move, in bytes.-  let sizeBytes :: Integer-      sizeBytes = fromIntegral (formatInBytes format)--  -- The number of instructions we will generate (approx). We need 2-  -- instructions per move.-  let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)--      go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr-      go dst src tmp i-          | i >= sizeBytes =-              unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`-              unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`-              go dst src tmp (i - sizeBytes)-          -- Deal with remaining bytes.-          | i >= 4 =  -- Will never happen on 32-bit-              unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`-              unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`-              go dst src tmp (i - 4)-          | i >= 2 =-              unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`-              unitOL (MOV    II16  (OpReg tmp) (OpAddr dst_addr)) `appOL`-              go dst src tmp (i - 2)-          | i >= 1 =-              unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`-              unitOL (MOV    II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`-              go dst src tmp (i - 1)-          | otherwise = nilOL-        where-          src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone-                       (ImmInteger (n - i))--          dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone-                       (ImmInteger (n - i))--  if insns > fromIntegral (ncgInlineThresholdMemcpy config)-    then pure Nothing-    else do-      code_dst <- getAnyReg dst-      dst_r <- getNewRegNat format-      code_src <- getAnyReg src-      src_r <- getNewRegNat format-      tmp_r <- getNewRegNat format-      pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL`-                      go dst_r src_r tmp_r (fromInteger n)---- | Set memory to the given byte------ Unroll memset calls if the number of bytes to copy isn't too large (cf--- ncgInlineThresholdMemset).  Otherwise, call C's memset.-genMemSet-  :: BlockId-  -> Int-  -> CmmExpr-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genMemSet bid align dst arg_c arg_n = do--  let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n]--  case (arg_c,arg_n) of-    (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do-      -- try to inline it-      mcode <- genMemSetInlineMaybe align dst c n-      -- if it didn't inline, call the C function-      case mcode of-        Nothing -> libc_memset-        Just c  -> pure c--    -- not literal size arguments: call the C function-    _ -> libc_memset--genMemSetInlineMaybe-  :: Int-  -> CmmExpr-  -> Integer-  -> Integer-  -> NatM (Maybe InstrBlock)-genMemSetInlineMaybe align dst c n = do-  config <- getConfig-  let-    platform = ncgPlatform config-    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported-    effectiveAlignment = min (alignmentOf align) maxAlignment-    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment-    c2 = c `shiftL` 8 .|. c-    c4 = c2 `shiftL` 16 .|. c2-    c8 = c4 `shiftL` 32 .|. c4--    -- The number of instructions we will generate (approx). We need 1-    -- instructions per move.-    insns = (n + sizeBytes - 1) `div` sizeBytes--    -- The size of each move, in bytes.-    sizeBytes :: Integer-    sizeBytes = fromIntegral (formatInBytes format)--    -- Depending on size returns the widest MOV instruction and its-    -- width.-    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)-    gen4 addr size-        | size >= 4 =-            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)-        | size >= 2 =-            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)-        | size >= 1 =-            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)-        | otherwise = (nilOL, 0)--    -- Generates a 64-bit wide MOV instruction from REG to MEM.-    gen8 :: AddrMode -> Reg -> InstrBlock-    gen8 addr reg8byte =-      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))--    -- Unrolls memset when the widest MOV is <= 4 bytes.-    go4 :: Reg -> Integer -> InstrBlock-    go4 dst left =-      if left <= 0 then nilOL-      else curMov `appOL` go4 dst (left - curWidth)-      where-        possibleWidth = minimum [left, sizeBytes]-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))-        (curMov, curWidth) = gen4 dst_addr possibleWidth--    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg-    -- argument). Falls back to go4 when all 8 byte moves are-    -- exhausted.-    go8 :: Reg -> Reg -> Integer -> InstrBlock-    go8 dst reg8byte left =-      if possibleWidth >= 8 then-        let curMov = gen8 dst_addr reg8byte-        in  curMov `appOL` go8 dst reg8byte (left - 8)-      else go4 dst left-      where-        possibleWidth = minimum [left, sizeBytes]+-----------------------------------------------------------------------------+--+-- Generating machine code (instruction selection)+--+-- (c) The University of Glasgow 1996-2004+--+-----------------------------------------------------------------------------++-- This is a big module, but, if you pay attention to+-- (a) the sectioning, and (b) the type signatures, the+-- structure should not be too overwhelming.++module GHC.CmmToAsm.X86.CodeGen (+        cmmTopCodeGen,+        generateJumpTableForInstr,+        extractUnwindPoints,+        invertCondBranches,+        InstrBlock+)++where++-- NCG stuff:+import GHC.Prelude++import GHC.CmmToAsm.X86.Instr+import GHC.CmmToAsm.X86.Cond+import GHC.CmmToAsm.X86.Regs+import GHC.CmmToAsm.X86.Ppr+import GHC.CmmToAsm.X86.RegInfo++import GHC.Platform.Regs+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Types+import GHC.Cmm.DebugBlock+   ( DebugBlock(..), UnwindPoint(..), UnwindTable+   , UnwindExpr(UwReg), toUnwindExpr+   )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Monad+   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat+   , getDeltaNat, getBlockIdNat, getPicBaseNat+   , Reg64(..), RegCode64(..), getNewReg64, localReg64+   , getPicBaseMaybeNat, getDebugBlock, getFileId+   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform+   , getCfgWeights+   )+import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config+import GHC.Platform.Reg+import GHC.Platform++-- Our intermediate code:+import GHC.Types.Basic+import GHC.Cmm.BlockId+import GHC.Unit.Types ( ghcInternalUnitId )+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.CLabel+import GHC.Types.Tickish ( GenTickish(..) )+import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )++-- The rest:+import GHC.Data.Maybe ( expectJust )+import GHC.Types.ForeignCall ( CCallConv(..) )+import GHC.Data.OrdList+import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Monad ( foldMapM )+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Types.Unique.DSM ( getUniqueM )++import qualified Data.Semigroup as S++import Control.Monad+import Control.Monad.Trans.State.Strict+  ( StateT, evalStateT, get, put )+import Control.Monad.Trans.Class (lift)+import Data.Foldable (fold)+import Data.Int+import Data.List (partition, (\\))+import Data.Maybe+import Data.Word++import qualified Data.Map as Map++is32BitPlatform :: NatM Bool+is32BitPlatform = do+    platform <- getPlatform+    return $ target32Bit platform++ssse3Enabled :: NatM Bool+ssse3Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSSE3)++sse4_1Enabled :: NatM Bool+sse4_1Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE4)++sse4_2Enabled :: NatM Bool+sse4_2Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE42)++avxEnabled :: NatM Bool+avxEnabled = do+  config <- getConfig+  return (ncgAvxEnabled config)++avx2Enabled :: NatM Bool+avx2Enabled = do+  config <- getConfig+  return (ncgAvx2Enabled config)++cmmTopCodeGen+        :: RawCmmDecl+        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]++cmmTopCodeGen (CmmProc info lab live graph) = do+  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  picBaseMb <- getPicBaseMaybeNat+  platform <- getPlatform+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics+      os   = platformOS platform++  case picBaseMb of+      Just picBase -> initializePicBase_x86 os picBase tops+      Nothing -> return tops++cmmTopCodeGen (CmmData sec dat) =+  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic++{- Note [Verifying basic blocks]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   We want to guarantee a few things about the results+   of instruction selection.++   Namely that each basic blocks consists of:+    * A (potentially empty) sequence of straight line instructions+  followed by+    * A (potentially empty) sequence of jump like instructions.++    We can verify this by going through the instructions and+    making sure that any non-jumpish instruction can't appear+    after a jumpish instruction.++    There are gotchas however:+    * CALLs are strictly speaking control flow but here we care+      not about them. Hence we treat them as regular instructions.++      It's safe for them to appear inside a basic block+      as (ignoring side effects inside the call) they will result in+      straight line code.++    * NEWBLOCK marks the start of a new basic block so can+      be followed by any instructions.+-}++-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.+verifyBasicBlock :: Platform -> [Instr] -> ()+verifyBasicBlock platform instrs+  | debugIsOn     = go False instrs+  | otherwise     = ()+  where+    go _     [] = ()+    go atEnd (i:instr)+        = case i of+            -- Start a new basic block+            NEWBLOCK {} -> go False instr+            -- Calls are not viable block terminators+            CALL {}     | atEnd -> faultyBlockWith i+                        | not atEnd -> go atEnd instr+            -- All instructions ok, check if we reached the end and continue.+            _ | not atEnd -> go (isJumpishInstr i) instr+              -- Only jumps allowed at the end of basic blocks.+              | otherwise -> if isJumpishInstr i+                                then go True instr+                                else faultyBlockWith i+    faultyBlockWith i+        = pprPanic "Non control flow instructions after end of basic block."+                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))++basicBlockCodeGen+        :: CmmBlock+        -> NatM ( [NatBasicBlock Instr]+                , [NatCmmDecl (Alignment, RawCmmStatics) Instr])++basicBlockCodeGen block = do+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes+  -- Generate location directive+  dbg <- getDebugBlock (entryLabel block)+  loc_instrs <- case dblSourceTick =<< dbg of+    Just (SourceNote span (LexicalFastString name))+      -> do fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            return $ unitOL $ LOCATION fileId line col (unpackFS name)+    _ -> return nilOL+  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts+  (!tail_instrs,_) <- stmtToInstrs mid_bid tail+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs+  platform <- getPlatform+  return $! verifyBasicBlock platform (fromOL instrs)+  instrs' <- fold <$> traverse addSpUnwindings instrs+  -- code generation may introduce new basic block boundaries, which+  -- are indicated by the NEWBLOCK instruction.  We must split up the+  -- instruction stream into basic blocks again.  Also, we extract+  -- LDATAs here too.+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'++        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+          = ([], BasicBlock id instrs : blocks, statics)+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)+          = (instrs, blocks, CmmData sec dat:statics)+        mkBlocks instr (instrs,blocks,statics)+          = (instr:instrs, blocks, statics)+  return (BasicBlock id top : other_blocks, statics)++-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes+-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"+-- for details.+addSpUnwindings :: Instr -> NatM (OrdList Instr)+addSpUnwindings instr@(DELTA d) = do+    config <- getConfig+    let platform = ncgPlatform config+    if ncgDwarfUnwindings config+        then do lbl <- mkAsmTempLabel <$> getUniqueM+                let unwind = Map.singleton MachSp (Just $ UwReg (GlobalRegUse MachSp (bWord platform)) $ negate d)+                return $ toOL [ instr, UNWIND lbl unwind ]+        else return (unitOL instr)+addSpUnwindings instr = return $ unitOL instr++{- Note [Keeping track of the current block]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating instructions for Cmm we sometimes require+the current block for things like retry loops.++We also sometimes change the current block, if a MachOP+results in branching control flow.++Issues arise if we have two statements in the same block,+which both depend on the current block id *and* change the+basic block after them. This happens for atomic primops+in the X86 backend where we want to update the CFG data structure+when introducing new basic blocks.++For example in #17334 we got this Cmm code:++        c3Bf: // global+            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);+            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);+            _s3sT::I64 = _s3sV::I64;+            goto c3B1;++This resulted in two new basic blocks being inserted:++        c3Bf:+                movl $18,%vI_n3Bo+                movq 88(%vI_s3sQ),%rax+                jmp _n3Bp+        n3Bp:+                ...+                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)+                jne _n3Bp+                ...+                jmp _n3Bs+        n3Bs:+                ...+                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)+                jne _n3Bs+                ...+                jmp _c3B1+        ...++Based on the Cmm we called stmtToInstrs we translated both atomic operations under+the assumption they would be placed into their Cmm basic block `c3Bf`.+However for the retry loop we introduce new labels, so this is not the case+for the second statement.+This resulted in a desync between the explicit control flow graph+we construct as a separate data type and the actual control flow graph in the code.++Instead we now return the new basic block if a statement causes a change+in the current block and use the block for all following statements.++For this reason genForeignCall is also split into two parts.  One for calls which+*won't* change the basic blocks in which successive instructions will be+placed (since they only evaluate CmmExpr, which can only contain MachOps, which+cannot introduce basic blocks in their lowerings).  A different one for calls+which *are* known to change the basic block.++-}++-- See Note [Keeping track of the current block] for why+-- we pass the BlockId.+stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.+              -> [CmmNode O O] -- ^ Cmm Statement+              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction+stmtsToInstrs bid stmts =+    go bid stmts nilOL+  where+    go bid  []        instrs = return (instrs,bid)+    go bid (s:stmts)  instrs = do+      (instrs',bid') <- stmtToInstrs bid s+      -- If the statement introduced a new block, we use that one+      let !newBid = fromMaybe bid bid'+      go newBid stmts (instrs `appOL` instrs')++-- | `bid` refers to the current block and is used to update the CFG+--   if new blocks are inserted in the control flow.+-- See Note [Keeping track of the current block] for more details.+stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.+             -> CmmNode e x+             -> NatM (InstrBlock, Maybe BlockId)+             -- ^ Instructions, and bid of new block if successive+             -- statements are placed in a different basic block.+stmtToInstrs bid stmt = do+  is32Bit <- is32BitPlatform+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+       -> genForeignCall target result_regs args bid++    _ -> (,Nothing) <$> case stmt of+      CmmComment s   -> return (unitOL (COMMENT s))+      CmmTick {}     -> return nilOL++      CmmUnwind regs -> do+        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable+            to_unwind_entry (reg, expr) = Map.singleton reg (fmap (toUnwindExpr platform) expr)+        case foldMap to_unwind_entry regs of+          tbl | Map.null tbl -> return nilOL+              | otherwise    -> do+                  lbl <- mkAsmTempLabel <$> getUniqueM+                  return $ unitOL $ UNWIND lbl tbl++      CmmAssign reg src+        | isFloatType ty         -> assignReg_FltCode reg src+        | is32Bit && isWord64 ty -> assignReg_I64Code reg src+        | isVecType ty           -> assignReg_VecCode reg src+        | otherwise              -> assignReg_IntCode reg src+          where ty = cmmRegType reg++      CmmStore addr src _alignment+        | isFloatType ty         -> assignMem_FltCode format addr src+        | is32Bit && isWord64 ty -> assignMem_I64Code        addr src+        | isVecType ty           -> assignMem_VecCode format addr src+        | otherwise              -> assignMem_IntCode format addr src+          where ty = cmmExprType platform src+                format = cmmTypeFormat ty++      CmmBranch id          -> return $ genBranch id++      --We try to arrange blocks such that the likely branch is the fallthrough+      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+      CmmCondBranch arg true false _ -> genCondBranch bid true false arg+      CmmSwitch arg ids -> genSwitch arg ids+      CmmCall { cml_target = arg+              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)+      _ ->+        panic "stmtToInstrs: statement should have been cps'd away"+++jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat]+jumpRegs platform gregs =+  [ RegWithFormat (RegReal r) (cmmTypeFormat ty)+  | GlobalRegUse gr ty <- gregs+  , Just r <- [globalRegMaybe platform gr] ]++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr+++-- | Condition codes passed up the tree.+--+data CondCode+        = CondCode Bool Cond InstrBlock+++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)+++swizzleRegisterRep :: Register -> Format -> Register+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn++getLocalRegReg :: LocalReg -> Reg+getLocalRegReg (LocalReg u ty)+  = -- by assuming SSE2, Int, Word, Float, Double and vectors all can be register allocated+    RegVirtual (mkVirtualReg u (cmmTypeFormat ty))++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform  -> CmmReg -> Reg++getRegisterReg _   (CmmLocal lreg) = getLocalRegReg lreg++getRegisterReg platform  (CmmGlobal mid)+  = case globalRegMaybe platform $ globalRegUse_reg mid of+        Just reg -> RegReal $ reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence ...++-- | Memory addressing modes passed up the tree.+data Amode+        = Amode AddrMode InstrBlock++{-+Now, given a tree (the argument to a CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to.  So you can't put+anything in between, lest it overwrite some of those registers.  If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++    code+    LEA amode, tmp+    ... other computation ...+    ... (tmp) ...+-}++{-+Note [%rip-relative addressing on x86-64]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set,+"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of+specification version 0.99).++In general the small code model would allow us to assume that code is located+between 0 and 2^31 - 1. However, this is not true on Windows which, due to+high-entropy ASLR, may place the executable image anywhere in 64-bit address+space. This is problematic since immediate operands in x86-64 are generally+32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding).+Consequently, to avoid overflowing we use %rip-relative addressing universally.+Since %rip-relative addressing comes essentially for free and makes linking far+easier, we use it even on non-Windows platforms.++See also: the documentation for GCC's `-mcmodel=small` flag.+-}+++-- | Check whether an integer will fit in 32 bits.+--      A CmmInt is intended to be truncated to the appropriate+--      number of bits, so here we truncate it to Int64.  This is+--      important because e.g. -1 as a CmmInt might be either+--      -1 or 18446744073709551615.+--+is32BitInteger :: Integer -> Bool+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000+  where i64 = fromIntegral i :: Int64+++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic+jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+    where blockLabel = blockLbl blockid+++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: CmmReg -> Int -> CmmExpr+mangleIndexTree reg off+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType reg)++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)++assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_I64Code addrTree valueTree = do+  Amode addr addr_code <- getAmode addrTree+  RegCode64 vcode rhi rlo <- iselExpr64 valueTree+  let+        -- Little-endian store+        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)+        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))+  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)+++assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_I64Code (CmmLocal dst) valueTree = do+   RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree+   let+         Reg64 r_dst_hi r_dst_lo = localReg64 dst+         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)+         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)+   return (+        vcode `snocOL` mov_lo `snocOL` mov_hi+     )++assignReg_I64Code _ _+   = panic "assignReg_I64Code(i386): invalid lvalue"++iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)+iselExpr64 (CmmLit (CmmInt i _)) = do+  Reg64 rhi rlo <- getNewReg64+  let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code = toOL [+                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),+                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)+                ]+  return (RegCode64 code rhi rlo)++iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do+   Amode addr addr_code <- getAmode addrTree+   Reg64 rhi rlo <- getNewReg64+   let+        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)+        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)+   return (+            RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo+     )++iselExpr64 (CmmReg (CmmLocal local_reg)) = do+  let Reg64 hi lo = localReg64 local_reg+  return (RegCode64 nilOL hi lo)++iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   Reg64 rhi rlo <- getNewReg64+   let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpReg r2hi) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       SUB II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SBB II32 (OpReg r2hi) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do+     code <- getAnyReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code r_dst_lo `snocOL`+                          XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi))+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_UU_Conv W16 W64) [expr]) = do+     (rsrc, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVZxL II16 (OpReg rsrc) (OpReg r_dst_lo),+                          XOR    II32 (OpReg r_dst_hi) (OpReg r_dst_hi)+                          ])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_UU_Conv W8 W64) [expr]) = do+     (rsrc, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVZxL II8 (OpReg rsrc) (OpReg r_dst_lo),+                          XOR    II32 (OpReg r_dst_hi) (OpReg r_dst_hi)+                          ])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do+     code <- getAnyReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code r_dst_lo `snocOL`+                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`+                          CLTD II32 `snocOL`+                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`+                          MOV II32 (OpReg edx) (OpReg r_dst_hi))+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W16 W64) [expr]) = do+     (r, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVSxL II16 (OpReg r) (OpReg eax),+                          CLTD II32,+                          MOV II32 (OpReg eax) (OpReg r_dst_lo),+                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W8 W64) [expr]) = do+     (r, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVSxL II8 (OpReg r) (OpReg eax),+                          CLTD II32,+                          MOV II32 (OpReg eax) (OpReg r_dst_lo),+                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_S_Neg _) [expr]) = do+   RegCode64 code rhi rlo <- iselExpr64 expr+   Reg64 rohi rolo <- getNewReg64+   let+        ocode = code `appOL`+                toOL [ MOV II32 (OpReg rlo) (OpReg rolo),+                       XOR II32 (OpReg rohi) (OpReg rohi),+                       NEGI II32 (OpReg rolo),+                       SBB II32 (OpReg rhi) (OpReg rohi) ]+   return (RegCode64 ocode rohi rolo)++-- To multiply two 64-bit numbers we use the following decomposition (in C notation):+--+--     ((r1hi << 32) + r1lo) * ((r2hi << 32) + r2lo)+--      = ((r2lo * r1hi) << 32)+--      + ((r1lo * r2hi) << 32)+--      + r1lo * r2lo+--+-- Note that @(r1hi * r2hi) << 64@ can be dropped because it overflows completely.++iselExpr64 (CmmMachOp (MO_Mul _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   tmp <- getNewRegNat II32+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV  II32 (OpReg r1lo) (OpReg eax),+                       MOV  II32 (OpReg r2lo) (OpReg tmp),+                       MOV  II32 (OpReg r1hi) (OpReg rhi),+                       IMUL II32 (OpReg tmp) (OpReg rhi),+                       MOV  II32 (OpReg r2hi) (OpReg rlo),+                       IMUL II32 (OpReg eax) (OpReg rlo),+                       ADD  II32 (OpReg rlo) (OpReg rhi),+                       MUL2 II32 (OpReg tmp),+                       ADD  II32 (OpReg edx) (OpReg rhi),+                       MOV  II32 (OpReg eax) (OpReg rlo)+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_S_MulMayOflo W64) _) = do+   -- Performance sensitive users won't use 32 bit so let's keep it simple:+   -- We always return a (usually false) positive.+   Reg64 rhi rlo <- getNewReg64+   let code = toOL   [+                       MOV II32 (OpImm (ImmInt 1)) (OpReg rhi),+                       MOV II32 (OpImm (ImmInt 1)) (OpReg rlo)+                     ]+   return (RegCode64 code rhi rlo)+++-- To shift a 64-bit number to the left we use the SHLD and SHL instructions.+-- We use SHLD to shift the bits in @rhi@ to the left while copying+-- high bits from @rlo@ to fill the new space in the low bits of @rhi@.+-- That leaves @rlo@ unchanged, so we use SHL to shift the bits of @rlo@ left.+-- However, both these instructions only use the lowest 5 bits from %cl to do+-- their shifting. So if the sixth bit (0x32) is set then we additionally move+-- the contents of @rlo@ to @rhi@ and clear @rlo@.++iselExpr64 (CmmMachOp (MO_Shl _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   code2 <- getAnyReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 ecx `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SHLD II32 (OpReg ecx) (OpReg rlo) (OpReg rhi),+                       SHL II32 (OpReg ecx) (OpReg rlo),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rlo) (OpReg rhi),+                       XOR II32 (OpReg rlo) (OpReg rlo),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++-- Similar to above, however now we're shifting to the right+-- and we're doing a signed shift which means that @rhi@ needs+-- to be set to either 0 if @rhi@ is positive or 0xffffffff otherwise,+-- and if the sixth bit of %cl is set (so the shift amount is more than 32).+-- To accomplish that we shift @rhi@ by 31.++iselExpr64 (CmmMachOp (MO_S_Shr _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   (r2, code2) <- getSomeReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       MOV II32 (OpReg r2) (OpReg ecx),+                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),+                       SAR II32 (OpReg ecx) (OpReg rhi),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rhi) (OpReg rlo),+                       SAR II32 (OpImm (ImmInt 31)) (OpReg rhi),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++-- Similar to the above.++iselExpr64 (CmmMachOp (MO_U_Shr _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   (r2, code2) <- getSomeReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       MOV II32 (OpReg r2) (OpReg ecx),+                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),+                       SHR II32 (OpReg ecx) (OpReg rhi),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rhi) (OpReg rlo),+                       XOR II32 (OpReg rhi) (OpReg rhi),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_And _) [e1,e2]) = iselExpr64ParallelBin AND e1 e2+iselExpr64 (CmmMachOp (MO_Or  _) [e1,e2]) = iselExpr64ParallelBin OR  e1 e2+iselExpr64 (CmmMachOp (MO_Xor _) [e1,e2]) = iselExpr64ParallelBin XOR e1 e2++iselExpr64 (CmmMachOp (MO_Not _) [e1]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       NOT II32 (OpReg rlo),+                       NOT II32 (OpReg rhi)+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmRegOff r i) = iselExpr64 (mangleIndexTree r i)++iselExpr64 expr+   = do+      platform <- getPlatform+      pprPanic "iselExpr64(i386)" (pdoc platform expr $+$ text (show expr))++iselExpr64ParallelBin :: (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> CmmExpr -> NatM (RegCode64 (OrdList Instr))+iselExpr64ParallelBin op e1 e2 = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       op  II32 (OpReg r2lo) (OpReg rlo),+                       op  II32 (OpReg r2hi) (OpReg rhi)+                     ]+   return (RegCode64 code rhi rlo)++--------------------------------------------------------------------------------++getRegister :: HasDebugCallStack => CmmExpr -> NatM Register+getRegister e = do platform <- getPlatform+                   is32Bit <- is32BitPlatform+                   getRegister' platform is32Bit e++getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register++getRegister' platform is32Bit (CmmReg reg)+  = case reg of+        CmmGlobal (GlobalRegUse PicBaseReg _)+         | is32Bit ->+            -- on x86_64, we have %rip for PicBaseReg, but it's not+            -- a full-featured register, it can only be used for+            -- rip-relative addressing.+            do reg' <- getPicBaseNat (archWordFormat is32Bit)+               return (Fixed (archWordFormat is32Bit) reg' nilOL)+        _ ->+          let ty = cmmRegType reg+              reg_fmt = cmmTypeFormat ty+          in return $ Fixed reg_fmt (getRegisterReg platform reg) nilOL++getRegister' platform is32Bit (CmmRegOff r n)+  = getRegister' platform is32Bit $ mangleIndexTree r n++getRegister' platform is32Bit (CmmMachOp (MO_RelaxedRead w) [e])+  = getRegister' platform is32Bit (CmmLoad e (cmmBits w) NaturallyAligned)++getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])+  = addAlignmentCheck align <$> getRegister' platform is32Bit e++-- for 32-bit architectures, support some 64 -> 32 bit conversions:+-- TO_W_(x), TO_W_(x >> 32)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  RegCode64 code rhi _rlo <- iselExpr64 x+  return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  RegCode64 code rhi _rlo <- iselExpr64 x+  return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W8) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  ro <- getNewRegNat II8+  return $ Fixed II8 ro (code `appOL` toOL [ MOVZxL II8 (OpReg rlo) (OpReg ro) ])++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W16) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  ro <- getNewRegNat II16+  return $ Fixed II16 ro (code `appOL` toOL [ MOVZxL II16 (OpReg rlo) (OpReg ro) ])++-- catch simple cases of zero- or sign-extended load+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II32 code)++-- catch simple cases of zero- or sign-extended load+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II32) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)),+                                     CmmLit displacement])+ | not is32Bit =+      return $ Any II64 (\dst -> unitOL $+        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))++getRegister' _ _ (CmmMachOp mop []) =+  pprPanic "getRegister(x86): nullary MachOp" (text $ show mop)++getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps+    avx    <- avxEnabled+    avx2   <- avx2Enabled+    case mop of+      MO_F_Neg w  -> sse2NegCode w x+++      MO_S_Neg w -> triv_ucode NEGI (intFormat w)+      MO_Not w   -> triv_ucode NOT  (intFormat w)++      -- Nop conversions+      MO_UU_Conv W32 W8  -> toI8Reg  W32 x+      MO_SS_Conv W32 W8  -> toI8Reg  W32 x+      MO_XX_Conv W32 W8  -> toI8Reg  W32 x+      MO_UU_Conv W16 W8  -> toI8Reg  W16 x+      MO_SS_Conv W16 W8  -> toI8Reg  W16 x+      MO_XX_Conv W16 W8  -> toI8Reg  W16 x+      MO_UU_Conv W32 W16 -> toI16Reg W32 x+      MO_SS_Conv W32 W16 -> toI16Reg W32 x+      MO_XX_Conv W32 W16 -> toI16Reg W32 x++      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x++      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x++      MO_FW_Bitcast W32 -> bitcast FF32 II32 x+      MO_WF_Bitcast W32 -> bitcast II32 FF32 x+      MO_FW_Bitcast W64 -> bitcast FF64 II64 x+      MO_WF_Bitcast W64 -> bitcast II64 FF64 x+      MO_WF_Bitcast {}  -> incorrectOperands+      MO_FW_Bitcast {}  -> incorrectOperands++      -- widenings+      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x+      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x+      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x++      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x+      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x+      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x++      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we+      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register+      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.+      MO_XX_Conv W8  W32+          | is32Bit   -> integerExtend W8 W32 MOVZxL x+          | otherwise -> integerExtend W8 W32 MOV x+      MO_XX_Conv W8  W16+          | is32Bit   -> integerExtend W8 W16 MOVZxL x+          | otherwise -> integerExtend W8 W16 MOV x+      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x++      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x+      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x+      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x+      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x+      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x+      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x+      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.+      -- However, we don't want the register allocator to throw it+      -- away as an unnecessary reg-to-reg move, so we keep it in+      -- the form of a movzl and print it as a movl later.+      -- This doesn't apply to MO_XX_Conv since in this case we don't care about+      -- the upper bits. So we can just use MOV.+      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x+      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x+      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x++      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x+      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x++      MO_FF_Conv from to -> invalidConversion from to+      MO_UU_Conv from to -> invalidConversion from to+      MO_SS_Conv from to -> invalidConversion from to+      MO_XX_Conv from to -> invalidConversion from to++      MO_FS_Truncate from to -> coerceFP2Int from to x+      MO_SF_Round    from to -> coerceInt2FP from to x++      MO_VF_Neg l w  | avx       -> vector_float_negate_avx l w x+                     | otherwise -> vector_float_negate_sse l w x+      -- SIMD NCG TODO: Support 256/512-bit integer vectors+      MO_VS_Neg l w -> getRegister' platform is32Bit (CmmMachOp (MO_V_Sub l w) [zero_vec, x])+        where zero_vec = CmmLit $ CmmVec $ replicate l $ CmmInt 0 w++      MO_VF_Broadcast l w+        | avx+        -> vector_float_broadcast_avx l w x+        | otherwise+        -> vector_float_broadcast_sse l w x+      MO_V_Broadcast l w+        | avx2, l * widthInBits w `elem` [128, 256] -- AVX-512 is not supported for now+        -> vector_int_broadcast_avx2 l w x+      MO_V_Broadcast 16 W8 -> vector_int8x16_broadcast x+      MO_V_Broadcast 8 W16 -> vector_int16x8_broadcast x+      MO_V_Broadcast 4 W32 -> vector_int32x4_broadcast x+      MO_V_Broadcast 2 W64 -> vector_int64x2_broadcast x+      MO_V_Broadcast {}+        -> pprPanic "Unsupported integer vector broadcast operation for: " (pdoc platform x)++      -- Binary MachOps+      MO_Add {}    -> incorrectOperands+      MO_Sub {}    -> incorrectOperands+      MO_Eq {}     -> incorrectOperands+      MO_Ne {}     -> incorrectOperands+      MO_Mul {}    -> incorrectOperands+      MO_S_MulMayOflo {} -> incorrectOperands+      MO_S_Quot {} -> incorrectOperands+      MO_S_Rem {}  -> incorrectOperands+      MO_U_Quot {} -> incorrectOperands+      MO_U_Rem {}  -> incorrectOperands+      MO_S_Ge {}   -> incorrectOperands+      MO_S_Le {}   -> incorrectOperands+      MO_S_Gt {}   -> incorrectOperands+      MO_S_Lt {}   -> incorrectOperands+      MO_U_Ge {}   -> incorrectOperands+      MO_U_Le {}   -> incorrectOperands+      MO_U_Gt {}   -> incorrectOperands+      MO_U_Lt {}   -> incorrectOperands+      MO_F_Add {}  -> incorrectOperands+      MO_F_Sub {}  -> incorrectOperands+      MO_F_Mul {}  -> incorrectOperands+      MO_F_Quot {} -> incorrectOperands+      MO_F_Eq {}   -> incorrectOperands+      MO_F_Ne {}   -> incorrectOperands+      MO_F_Ge {}   -> incorrectOperands+      MO_F_Le {}   -> incorrectOperands+      MO_F_Gt {}   -> incorrectOperands+      MO_F_Lt {}   -> incorrectOperands+      MO_F_Min {}  -> incorrectOperands+      MO_F_Max {}  -> incorrectOperands+      MO_And {}    -> incorrectOperands+      MO_Or {}     -> incorrectOperands+      MO_Xor {}    -> incorrectOperands+      MO_Shl {}    -> incorrectOperands+      MO_U_Shr {}  -> incorrectOperands+      MO_S_Shr {}  -> incorrectOperands++      MO_V_Extract {}     -> incorrectOperands+      MO_V_Add {}         -> incorrectOperands+      MO_V_Sub {}         -> incorrectOperands+      MO_V_Mul {}         -> incorrectOperands+      MO_V_Shuffle {}     -> incorrectOperands+      MO_VF_Shuffle {}    -> incorrectOperands+      MO_VU_Min {}  -> incorrectOperands+      MO_VU_Max {}  -> incorrectOperands+      MO_VS_Min {}  -> incorrectOperands+      MO_VS_Max {}  -> incorrectOperands+      MO_VF_Min {}  -> incorrectOperands+      MO_VF_Max {}  -> incorrectOperands++      MO_VF_Extract {}    -> incorrectOperands+      MO_VF_Add {}        -> incorrectOperands+      MO_VF_Sub {}        -> incorrectOperands+      MO_VF_Mul {}        -> incorrectOperands+      MO_VF_Quot {}       -> incorrectOperands++      -- Ternary MachOps+      MO_FMA {}           -> incorrectOperands+      MO_VF_Insert {}     -> incorrectOperands+      MO_V_Insert {}      -> incorrectOperands++      --_other -> pprPanic "getRegister" (pprMachOp mop)+   where+        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register+        triv_ucode instr format = trivialUCode format (instr format) x++        -- signed or unsigned extension.+        integerExtend :: Width -> Width+                      -> (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> NatM Register+        integerExtend from to instr expr = do+            (reg,e_code) <- if from == W8 then getByteReg expr+                                          else getSomeReg expr+            let+                code dst =+                  e_code `snocOL`+                  instr (intFormat from) (OpReg reg) (OpReg dst)+            return (Any (intFormat to) code)++        bitcast :: Format -> Format -> CmmExpr -> NatM Register+        bitcast fmt rfmt expr =+          do (src, e_code) <- getSomeReg expr+             let code = \dst -> e_code `snocOL` (MOVD fmt rfmt (OpReg src) (OpReg dst))+             return (Any rfmt code)++        toI8Reg :: Width -> CmmExpr -> NatM Register+        toI8Reg new_rep expr+            = do codefn <- getAnyReg expr+                 return (Any (intFormat new_rep) codefn)+                -- HACK: use getAnyReg to get a byte-addressable register.+                -- If the source was a Fixed register, this will add the+                -- mov instruction to put it into the desired destination.+                -- We're assuming that the destination won't be a fixed+                -- non-byte-addressable register; it won't be, because all+                -- fixed registers are word-sized.++        toI16Reg = toI8Reg -- for now++        conversionNop :: Format -> CmmExpr -> NatM Register+        conversionNop new_format expr+            = do e_code <- getRegister' platform is32Bit expr+                 return (swizzleRegisterRep e_code new_format)++        vector_float_negate_avx :: Length -> Width -> CmmExpr -> NatM Register+        vector_float_negate_avx l w expr = do+          let fmt :: Format+              mask :: CmmLit+              (fmt, mask) = case w of+                       W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- TODO: these should be negative 0 floating point literals,+                       W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- but we don't currently have those in Cmm.+                       _ -> panic "AVX floating-point negation: elements must be FF32 or FF64"+          (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask)+          (reg, exp) <- getSomeReg expr+          let code dst = maskCode `appOL`+                         exp `snocOL`+                         (VMOVU fmt (OpReg reg) (OpReg dst)) `snocOL`+                         (VXOR fmt (OpReg maskReg) dst dst)+          return (Any fmt code)++        vector_float_negate_sse :: Length -> Width -> CmmExpr -> NatM Register+        vector_float_negate_sse l w expr = do+          let fmt :: Format+              mask :: CmmLit+              (fmt, mask) = case w of+                       W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- Same comment as for vector_float_negate_avx,+                       W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- these should be -0.0 CmmFloat values.+                       _ -> panic "SSE floating-point negation: elements must be FF32 or FF64"+          (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask)+          (reg, exp) <- getSomeReg expr+          let code dst = maskCode `appOL`+                         exp `snocOL`+                         (MOVU fmt (OpReg reg) (OpReg dst)) `snocOL`+                         (XOR  fmt (OpReg maskReg) (OpReg dst))+          return (Any fmt code)++        -----------------------++        -- TODO: we could use VBROADCASTSS/SD when AVX2 is available.+        vector_float_broadcast_avx :: Length+                                   -> Width+                                   -> CmmExpr+                                   -> NatM Register+        vector_float_broadcast_avx len w expr = do+          (dst, exp) <- getSomeReg expr+          let fmt = VecFormat len (floatScalarFormat w)+              code = VSHUF fmt (ImmInt 0) (OpReg dst) dst dst+          return $ Fixed fmt dst (exp `snocOL` code)++        vector_float_broadcast_sse :: Length+                                   -> Width+                                   -> CmmExpr+                                   -> NatM Register+        vector_float_broadcast_sse len w expr = do+          (dst, exp) <- getSomeReg expr+          let fmt = VecFormat len (floatScalarFormat w)+              code = SHUF fmt (ImmInt 0) (OpReg dst) dst+          return $ Fixed fmt dst (exp `snocOL` code)++        vector_int_broadcast_avx2 :: Length+                                  -> Width+                                  -> CmmExpr+                                  -> NatM Register+        vector_int_broadcast_avx2 len w expr = do+          (reg, exp) <- getNonClobberedReg expr+          let (movFormat, fmt) = case w of+                W8  -> (II32, VecFormat len FmtInt8)+                W16 -> (II32, VecFormat len FmtInt16)+                W32 -> (II32, VecFormat len FmtInt32)+                W64 -> (II64, VecFormat len FmtInt64)+                _   -> pprPanic "Broadcast not supported for: " (pdoc platform expr)+              code dst = exp `snocOL`+                         -- VPBROADCAST from GPR requires AVX-512,+                         -- so we use an additional MOVD.+                         (MOVD movFormat fmt (OpReg reg) (OpReg dst)) `snocOL`+                         (VPBROADCAST fmt fmt (OpReg dst) dst)+          return $ Any fmt code++        vector_int8x16_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int8x16_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 16 FmtInt8+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PUNPCKLBW fmt (OpReg dst) dst) `snocOL`+                                    (PUNPCKLWD (VecFormat 8 FmtInt16) (OpReg dst) dst) `snocOL`+                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)+                                    )++        vector_int16x8_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int16x8_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 8 FmtInt16+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PUNPCKLWD fmt (OpReg dst) dst) `snocOL`+                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)+                                    )++        vector_int32x4_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int32x4_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 4 FmtInt32+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)+                                    )++        vector_int64x2_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int64x2_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 2 FmtInt64+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II64 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PUNPCKLQDQ fmt (OpReg dst) dst)+                                    )++getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps+  sse4_1 <- sse4_1Enabled+  sse4_2 <- sse4_2Enabled+  avx <- avxEnabled+  case mop of+      MO_F_Eq _ -> condFltReg is32Bit EQQ x y+      MO_F_Ne _ -> condFltReg is32Bit NE  x y+      MO_F_Gt _ -> condFltReg is32Bit GTT x y+      MO_F_Ge _ -> condFltReg is32Bit GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt _ -> condFltReg is32Bit GTT  y x+      MO_F_Le _ -> condFltReg is32Bit GE   y x++      MO_Eq _   -> condIntReg EQQ x y+      MO_Ne _   -> condIntReg NE  x y++      MO_S_Gt _ -> condIntReg GTT x y+      MO_S_Ge _ -> condIntReg GE  x y+      MO_S_Lt _ -> condIntReg LTT x y+      MO_S_Le _ -> condIntReg LE  x y++      MO_U_Gt _ -> condIntReg GU  x y+      MO_U_Ge _ -> condIntReg GEU x y+      MO_U_Lt _ -> condIntReg LU  x y+      MO_U_Le _ -> condIntReg LEU x y++      MO_F_Add  w -> trivialFCode_sse2 w (\fmt op2 -> ADD fmt op2 . OpReg) x y+      MO_F_Sub  w -> trivialFCode_sse2 w (\fmt op2 -> SUB fmt op2 . OpReg) x y+      MO_F_Quot w -> trivialFCode_sse2 w FDIV x y+      MO_F_Mul  w -> trivialFCode_sse2 w (\fmt op2 -> MUL fmt op2 . OpReg) x y+      MO_F_Min  w -> trivialFCode_sse2 w (MINMAX Min FloatMinMax) x y+      MO_F_Max  w -> trivialFCode_sse2 w (MINMAX Max FloatMinMax) x y++      MO_Add rep -> add_code rep x y+      MO_Sub rep -> sub_code rep x y++      MO_S_Quot rep -> div_code rep True  True  x y+      MO_S_Rem  rep -> div_code rep True  False x y+      MO_U_Quot rep -> div_code rep False True  x y+      MO_U_Rem  rep -> div_code rep False False x y++      MO_S_MulMayOflo rep -> imulMayOflo rep x y++      MO_Mul W8  -> imulW8 x y+      MO_Mul rep -> triv_op rep IMUL+      MO_And rep -> triv_op rep AND+      MO_Or  rep -> triv_op rep OR+      MO_Xor rep -> triv_op rep XOR++        {- Shift ops on x86s have constraints on their source, it+           either has to be Imm, CL or 1+            => trivialCode is not restrictive enough (sigh.)+        -}+      MO_Shl rep   -> shift_code rep SHL x y {-False-}+      MO_U_Shr rep -> shift_code rep SHR x y {-False-}+      MO_S_Shr rep -> shift_code rep SAR x y {-False-}++      MO_VF_Shuffle 4 W32 is | avx -> vector_shuffle_float_avx 4 x y is+                             | otherwise -> vector_shuffle_floatx4_sse sse4_1 x y is+      MO_VF_Shuffle 2 W64 is | avx -> vector_shuffle_double_avx 2 x y is+                             | otherwise -> vector_shuffle_doublex2_sse x y is+      MO_VF_Shuffle {} -> sorry "Please use -fllvm for wide shuffle instructions"++      MO_VF_Extract l W32   | avx       -> vector_float_extract l W32 x y+                            | otherwise -> vector_float_extract_sse l W32 x y+      MO_VF_Extract l W64               -> vector_float_extract l W64 x y+      MO_VF_Extract {} -> incorrectOperands++      MO_V_Extract 16 W8 | sse4_1 -> vector_int_extract_pextr 16 W8 x y+                         | otherwise -> vector_int8x16_extract_sse2 x y+      MO_V_Extract 8 W16 -> vector_int_extract_pextr 8 W16 x y -- PEXTRW (SSE2)+      MO_V_Extract 4 W32 | sse4_1 -> vector_int_extract_pextr 4 W32 x y+                         | otherwise -> vector_int32x4_extract_sse2 x y+      MO_V_Extract 2 W64 | sse4_1 -> vector_int_extract_pextr 2 W64 x y+                         | otherwise -> vector_int64x2_extract_sse2 x y+      -- SIMD NCG TODO: 256/512-bit vector+      MO_V_Extract {} -> needLlvm mop++      MO_VF_Add l w         | avx       -> vector_float_op_avx VADD l w x y+                            | otherwise -> vector_float_op_sse (\fmt op2 -> ADD fmt op2 . OpReg) l w x y++      MO_VF_Sub l w         | avx       -> vector_float_op_avx VSUB l w x y+                            | otherwise -> vector_float_op_sse (\fmt op2 -> SUB fmt op2 . OpReg) l w x y++      MO_VF_Mul l w         | avx       -> vector_float_op_avx VMUL l w x y+                            | otherwise -> vector_float_op_sse (\fmt op2 -> MUL fmt op2 . OpReg) l w x y++      MO_VF_Quot l w        | avx       -> vector_float_op_avx VDIV l w x y+                            | otherwise -> vector_float_op_sse FDIV l w x y++      MO_VF_Min l w         | avx       -> vector_float_op_avx (VMINMAX Min FloatMinMax) l w x y+                            | otherwise -> vector_float_op_sse (MINMAX Min FloatMinMax) l w x y++      MO_VF_Max l w         | avx       -> vector_float_op_avx (VMINMAX Max FloatMinMax) l w x y+                            | otherwise -> vector_float_op_sse (MINMAX Max FloatMinMax) l w x y++      -- SIMD NCG TODO: 256/512-bit integer vector operations+      MO_V_Shuffle 16 W8 is | not is32Bit -> vector_shuffle_int8x16 sse4_1 x y is+      MO_V_Shuffle 8 W16 is -> vector_shuffle_int16x8 sse4_1 x y is+      MO_V_Shuffle 4 W32 is -> vector_shuffle_int32x4 sse4_1 x y is+      MO_V_Shuffle 2 W64 is -> vector_shuffle_int64x2 sse4_1 x y is+      MO_V_Shuffle {} -> needLlvm mop+      MO_V_Add l w | l * widthInBits w == 128 -> vector_int_op_sse PADD l w x y+                   | otherwise -> needLlvm mop+      MO_V_Sub l w | l * widthInBits w == 128 -> vector_int_op_sse PSUB l w x y+                   | otherwise -> needLlvm mop+      MO_V_Mul 16 W8 -> vector_int8x16_mul_sse2 x y+      MO_V_Mul l@8 w@W16 -> vector_int_op_sse PMULL l w x y -- PMULLW (SSE2)+      MO_V_Mul l@4 w@W32 | sse4_1 -> vector_int_op_sse PMULL l w x y -- PMULLD (SSE4.1)+                         | otherwise -> vector_int32x4_mul_sse2 x y+      MO_V_Mul 2 W64 -> vector_int64x2_mul_sse2 x y+      MO_V_Mul {} -> needLlvm mop++      MO_VU_Min l@16 w@W8+                    -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUB (SSE2)+      MO_VU_Min l@8 w@W16+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUW (SSE4.1)+        | otherwise -> vector_word_minmax_sse Min l w x y+      MO_VU_Min l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUD (SSE4.1)+        | otherwise -> vector_word_minmax_sse Min l w x y+      MO_VU_Min l@2 w@W64+        | sse4_2    -> vector_word_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_W64X2_Min)+      MO_VU_Min {} -> needLlvm mop+      MO_VU_Max l@16 w@W8+                    -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUB (SSE2)+      MO_VU_Max l@8 w@W16+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUW (SSE4.1)+        | otherwise -> vector_word_minmax_sse Max l w x y+      MO_VU_Max l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUD (SSE4.1)+        | otherwise -> vector_word_minmax_sse Max l w x y+      MO_VU_Max l@2 w@W64+        | sse4_2    -> vector_word_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_W64X2_Max)+      MO_VU_Max {} -> needLlvm mop+      MO_VS_Min l@16 w@W8+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSB (SSE4.1)+        | otherwise -> vector_int_minmax_sse Min l w x y+      MO_VS_Min l@8 w@W16+                    -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSW (SSE2)+      MO_VS_Min l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSD (SSE4.1)+        | otherwise -> vector_int_minmax_sse Min l w x y+      MO_VS_Min l@2 w@W64+        | sse4_2    -> vector_int_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_I64X2_Min)+      MO_VS_Min {} -> needLlvm mop+      MO_VS_Max l@16 w@W8+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSB (SSE4.1)+        | otherwise -> vector_int_minmax_sse Max l w x y+      MO_VS_Max l@8 w@W16+                    -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSW (SSE2)+      MO_VS_Max l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSD (SSE4.1)+        | otherwise -> vector_int_minmax_sse Max l w x y+      MO_VS_Max l@2 w@W64+        | sse4_2    -> vector_int_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_I64X2_Max)+      MO_VS_Max {} -> needLlvm mop++      -- Unary MachOps+      MO_S_Neg {} -> incorrectOperands+      MO_F_Neg {} -> incorrectOperands+      MO_Not {} -> incorrectOperands+      MO_SF_Round {} -> incorrectOperands+      MO_FS_Truncate {} -> incorrectOperands+      MO_SS_Conv {} -> incorrectOperands+      MO_XX_Conv {} -> incorrectOperands+      MO_FF_Conv {} -> incorrectOperands+      MO_UU_Conv {} -> incorrectOperands+      MO_WF_Bitcast {} -> incorrectOperands+      MO_FW_Bitcast  {} -> incorrectOperands+      MO_RelaxedRead {} -> incorrectOperands+      MO_AlignmentCheck {} -> incorrectOperands+      MO_VS_Neg {} -> incorrectOperands+      MO_VF_Neg {} -> incorrectOperands+      MO_V_Broadcast {} -> incorrectOperands+      MO_VF_Broadcast {} -> incorrectOperands++      -- Ternary MachOps+      MO_FMA {} -> incorrectOperands+      MO_V_Insert {} -> incorrectOperands+      MO_VF_Insert {} -> incorrectOperands++  where+    --------------------+    triv_op width instr = trivialCode width op (Just op) x y+                        where op   = instr (intFormat width)++    -- Special case for IMUL for bytes, since the result of IMULB will be in+    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider+    -- values.+    imulW8 :: CmmExpr -> CmmExpr -> NatM Register+    imulW8 arg_a arg_b = do+        (a_reg, a_code) <- getNonClobberedReg arg_a+        b_code <- getAnyReg arg_b++        let code = a_code `appOL` b_code eax `appOL`+                   toOL [ IMUL2 format (OpReg a_reg) ]+            format = intFormat W8++        return (Fixed format eax code)++    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    imulMayOflo W8 a b = do+         -- The general case (W16, W32, W64) doesn't work for W8 as its+         -- multiplication doesn't use two registers.+         --+         -- The plan is:+         -- 1. truncate and sign-extend a and b to 8bit width+         -- 2. multiply a' = a * b in 32bit width+         -- 3. copy and sign-extend 8bit from a' to c+         -- 4. compare a' and c: they are equal if there was no overflow+         (a_reg, a_code) <- getNonClobberedReg a+         (b_reg, b_code) <- getNonClobberedReg b+         let+             code = a_code `appOL` b_code `appOL`+                        toOL [+                           MOVSxL II8 (OpReg a_reg) (OpReg a_reg),+                           MOVSxL II8 (OpReg b_reg) (OpReg b_reg),+                           IMUL II32 (OpReg b_reg) (OpReg a_reg),+                           MOVSxL II8 (OpReg a_reg) (OpReg eax),+                           CMP II16 (OpReg a_reg) (OpReg eax),+                           SETCC NE (OpReg eax)+                        ]+         return (Fixed II8 eax code)+    imulMayOflo rep a b = do+         (a_reg, a_code) <- getNonClobberedReg a+         b_code <- getAnyReg b+         let+             shift_amt  = case rep of+                           W16 -> 15+                           W32 -> 31+                           W64 -> 63+                           w -> panic ("shift_amt: " ++ show w)++             format = intFormat rep+             code = a_code `appOL` b_code eax `appOL`+                        toOL [+                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax+                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),+                                -- sign extend lower part+                           SUB format (OpReg edx) (OpReg eax)+                                -- compare against upper+                           -- eax==0 if high part == sign extended low part+                        ]+         return (Fixed format eax code)++    --------------------+    shift_code :: Width+               -> (Format -> Operand -> Operand -> Instr)+               -> CmmExpr+               -> CmmExpr+               -> NatM Register++    {- Case1: shift length as immediate -}+    shift_code width instr x (CmmLit lit)+      -- Handle the case of a shift larger than the width of the shifted value.+      -- This is necessary since x86 applies a mask of 0x1f to the shift+      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by+      -- `47 & 0x1f == 15`. See #20626.+      | CmmInt n _ <- lit+      , n >= fromIntegral (widthInBits width)+      = getRegister $ CmmLit $ CmmInt 0 width++      | otherwise = do+          x_code <- getAnyReg x+          let+               format = intFormat width+               code dst+                  = x_code dst `snocOL`+                    instr format (OpImm (litToImm lit)) (OpReg dst)+          return (Any format code)++    {- Case2: shift length is complex (non-immediate)+      * y must go in %ecx.+      * we cannot do y first *and* put its result in %ecx, because+        %ecx might be clobbered by x.+      * if we do y second, then x cannot be+        in a clobbered reg.  Also, we cannot clobber x's reg+        with the instruction itself.+      * so we can either:+        - do y first, put its result in a fresh tmp, then copy it to %ecx later+        - do y second and put its result into %ecx.  x gets placed in a fresh+          tmp.  This is likely to be better, because the reg alloc can+          eliminate this reg->reg move here (it won't eliminate the other one,+          because the move is into the fixed %ecx).+      * in the case of C calls the use of ecx here can interfere with arguments.+        We avoid this with the hack described in Note [Evaluate C-call+        arguments before placing in destination registers]+    -}+    shift_code width instr x y{-amount-} = do+        x_code <- getAnyReg x+        let format = intFormat width+        tmp <- getNewRegNat format+        y_code <- getAnyReg y+        let+           code = x_code tmp `appOL`+                  y_code ecx `snocOL`+                  instr format (OpReg ecx) (OpReg tmp)+        return (Fixed format tmp code)++    --------------------+    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    add_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger y+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x y+    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y+      where format = intFormat rep+    -- TODO: There are other interesting patterns we want to replace+    --     with a LEA, e.g. `(x + offset) + (y << shift)`.++    --------------------+    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    sub_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger (-y)+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x (-y)+    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y++    -- our three-operand add instruction:+    add_int width x y = do+        (x_reg, x_code) <- getSomeReg x+        let+            format = intFormat width+            imm = ImmInt (fromInteger y)+            code dst+               = x_code `snocOL`+                 LEA format+                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))+                        (OpReg dst)+        --+        return (Any format code)++    ----------------------++    -- See Note [DIV/IDIV for bytes]+    div_code W8 signed quotient x y = do+        let widen | signed    = MO_SS_Conv W8 W16+                  | otherwise = MO_UU_Conv W8 W16+        div_code+            W16+            signed+            quotient+            (CmmMachOp widen [x])+            (CmmMachOp widen [y])++    div_code width signed quotient x y = do+           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered+           x_code <- getAnyReg x+           let+             format = intFormat width+             widen | signed    = CLTD format+                   | otherwise = XOR format (OpReg edx) (OpReg edx)++             instr | signed    = IDIV+                   | otherwise = DIV++             code = y_code `appOL`+                    x_code eax `appOL`+                    toOL [widen, instr format y_op]++             result | quotient  = eax+                    | otherwise = edx++           return (Fixed format result code)++    -----------------------+    -- Vector operations---+    vector_float_op_avx :: (Format -> Operand -> Reg -> Reg -> Instr)+                        -> Length+                        -> Width+                        -> CmmExpr+                        -> CmmExpr+                        -> NatM Register+    vector_float_op_avx instr l w = vector_op_avx_reg (\fmt -> instr fmt . OpReg) format+      where format = case w of+                       W32 -> VecFormat l FmtFloat+                       W64 -> VecFormat l FmtDouble+                       _ -> pprPanic "Floating-point AVX vector operation not supported at this width"+                             (text "width:" <+> ppr w)++    vector_op_avx_reg :: (Format -> Reg -> Reg -> Reg -> Instr)+                      -> Format+                      -> CmmExpr+                      -> CmmExpr+                      -> NatM Register+    vector_op_avx_reg instr format expr1 expr2 = do+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- getSomeReg expr2+      let -- opcode src2 src1 dst <==> dst = src1 `opcode` src2+          code dst = exp1 `appOL` exp2 `snocOL`+                     (instr format reg2 reg1 dst)+      return (Any format code)++    vector_float_op_sse :: (Format -> Operand -> Reg -> Instr)+                        -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_float_op_sse instr l w = vector_op_sse instr format+      where format = case w of+                       W32 -> VecFormat l FmtFloat+                       W64 -> VecFormat l FmtDouble+                       _ -> pprPanic "Floating-point SSE vector operation not supported at this width"+                             (text "width:" <+> ppr w)++    vector_int_op_sse :: (Format -> Operand -> Reg -> Instr)+                      -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_int_op_sse instr l w = vector_op_sse instr format+      where format = case w of+                       W8 -> VecFormat l FmtInt8+                       W16 -> VecFormat l FmtInt16+                       W32 -> VecFormat l FmtInt32+                       W64 -> VecFormat l FmtInt64+                       _ -> pprPanic "Integer SSE vector operation not supported at this width"+                              (text "width:" <+> ppr w)++    -- This function is similar to genTrivialCode, but re-using it would require+    -- handling alignment correctly: SSE vector instructions typically require 16-byte+    -- alignment for their memory operand (this restriction is relaxed with VEX-encoded+    -- instructions).+    -- For now, we always load the value into a register and avoid the alignment issue.+    vector_op_sse :: (Format -> Operand -> Reg -> Instr)+                  -> Format+                  -> CmmExpr+                  -> CmmExpr+                  -> NatM Register+    vector_op_sse instr = vector_op_sse_reg (\fmt -> instr fmt . OpReg)++    vector_op_sse_reg :: (Format -> Reg -> Reg -> Instr)+                      -> Format+                      -> CmmExpr+                      -> CmmExpr+                      -> NatM Register+    vector_op_sse_reg instr format expr1 expr2 = do+      config <- getConfig+      exp1_code <- getAnyReg expr1+      (reg2, exp2_code) <- getSomeReg expr2 -- vector registers are never clobbered by an instruction+      tmp <- getNewRegNat format+      let code dst+            -- opcode src2 src1 <==> src1 = src1 `opcode` src2+            | dst == reg2 = exp2_code `snocOL`+                            movInstr config format (OpReg reg2) (OpReg tmp) `appOL` -- MOVU or MOVDQU+                            exp1_code dst `snocOL`+                            instr format tmp dst+            | otherwise = exp2_code `appOL`+                          exp1_code dst `snocOL`+                          instr format reg2 dst+      return (Any format code)+    --------------------+    vector_float_extract :: Length+                         -> Width+                         -> CmmExpr+                         -> CmmExpr+                         -> NatM Register+    vector_float_extract l W32 expr (CmmLit lit) = do+      (r, exp) <- getSomeReg expr+      let format   = VecFormat l FmtFloat+          imm      = litToImm lit+          code dst+            = case lit of+                CmmInt 0 _ -> exp `snocOL` (MOV FF32 (OpReg r) (OpReg dst))+                CmmInt _ _ -> exp `snocOL` (VPSHUFD format imm (OpReg r) dst)+                _          -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit)+      return (Any FF32 code)+    vector_float_extract _ W64 expr (CmmLit lit) = do+      (r, exp) <- getSomeReg expr+      let code dst+            = case lit of+                CmmInt 0 _ -> exp `snocOL`+                              (MOV FF64 (OpReg r) (OpReg dst))+                CmmInt 1 _ -> exp `snocOL`+                              (MOVHLPS FF64 r dst)+                _          -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit)+      return (Any FF64 code)+    vector_float_extract _ w c e =+      pprPanic "Unsupported AVX floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w)+    -----------------------++    vector_float_extract_sse :: Length+                             -> Width+                             -> CmmExpr+                             -> CmmExpr+                             -> NatM Register+    vector_float_extract_sse l W32 expr (CmmLit lit)+      = do+      (r,exp) <- getSomeReg expr+      let format   = VecFormat l FmtFloat+          imm      = litToImm lit+          code dst+            = case lit of+                CmmInt 0 _ -> exp `snocOL` (MOVU format (OpReg r) (OpReg dst))+                CmmInt _ _ -> exp `snocOL` (PSHUFD format imm (OpReg r) dst)+                _          -> pprPanic "Unsupported SSE floating-point vector extract offset" (ppr lit)+      return (Any FF32 code)+    vector_float_extract_sse _ w c e+      = pprPanic "Unsupported SSE floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w)+    -----------------------++    -- PEXTRW ("to GPR" variant) is an SSE2 instruction,+    -- whereas PEXTR{B,D,Q} and PEXTRW ("to memory" variant) require SSE4.1.+    vector_int_extract_pextr :: Length+                             -> Width+                             -> CmmExpr+                             -> CmmExpr+                             -> NatM Register+    vector_int_extract_pextr l w expr (CmmLit (CmmInt i _))+      | 0 <= i, i < toInteger l+      = do+      (r, exp) <- getSomeReg expr -- vector registers are never clobbered by an instruction+      let (scalarFormat, vectorFormat) = case w of+            W8 -> (II32, VecFormat l FmtInt8)+            W16 -> (II32, VecFormat l FmtInt16)+            W32 -> (II32, VecFormat l FmtInt32)+            W64 -> (II64, VecFormat l FmtInt64)+            _ -> sorry "Unsupported vector format"+          code dst = exp `snocOL`+                     (PEXTR scalarFormat vectorFormat (ImmInteger i) r (OpReg dst))+      return (Any scalarFormat code)+    vector_int_extract_pextr _ _ _ i+      = pprPanic "Unsupported offset" (pdoc platform i)++    vector_int8x16_extract_sse2 :: CmmExpr+                                -> CmmExpr+                                -> NatM Register+    vector_int8x16_extract_sse2 expr (CmmLit (CmmInt i _))+      | 0 <= i, i < 16+      = do+      (r, exp) <- getSomeReg expr+      let code dst =+            case i `quotRem` 2 of+              (j, 0) -> exp `snocOL`+                        (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) -- PEXTRW+              (j, _) -> exp `snocOL`+                        (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) `snocOL` -- PEXTRW+                        (SHR II32 (OpImm (ImmInt 8)) (OpReg dst))+      return (Any II8 code)+    vector_int8x16_extract_sse2 _ offset+      = pprPanic "Unsupported offset" (pdoc platform offset)++    vector_int32x4_extract_sse2 :: CmmExpr+                                -> CmmExpr+                                -> NatM Register+    vector_int32x4_extract_sse2 expr (CmmLit (CmmInt i _))+      | 0 <= i, i < 4+      = do+      (r, exp) <- getSomeReg expr+      let fmt = VecFormat 4 FmtInt32+      tmp <- getNewRegNat fmt+      let code dst =+            case i of+              0 -> exp `snocOL`+                   (MOVD fmt II32 (OpReg r) (OpReg dst))+              1 -> exp `snocOL`+                   (PSHUFD fmt (ImmInt 0b01_01_01_01) (OpReg r) tmp) `snocOL` -- tmp <- (r[1],r[1],r[1],r[1])+                   (MOVD fmt II32 (OpReg tmp) (OpReg dst))+              2 -> exp `snocOL`+                   (PSHUFD fmt (ImmInt 0b11_10_11_10) (OpReg r) tmp) `snocOL` -- tmp <- (r[2],r[3],r[2],r[3])+                   (MOVD fmt II32 (OpReg tmp) (OpReg dst))+              _ -> exp `snocOL`+                   (PSHUFD fmt (ImmInt 0b11_11_11_11) (OpReg r) tmp) `snocOL` -- tmp <- (r[3],r[3],r[3],r[3])+                   (MOVD fmt II32 (OpReg tmp) (OpReg dst))+      return (Any II32 code)+    vector_int32x4_extract_sse2 _ offset+      = pprPanic "Unsupported offset" (pdoc platform offset)++    vector_int64x2_extract_sse2 :: CmmExpr+                                -> CmmExpr+                                -> NatM Register+    vector_int64x2_extract_sse2 expr (CmmLit lit)+      = do+      (r, exp) <- getSomeReg expr+      let fmt = VecFormat 2 FmtInt64+      tmp <- getNewRegNat fmt+      let code dst =+            case lit of+              CmmInt 0 _ -> exp `snocOL`+                            (MOVD fmt II64 (OpReg r) (OpReg dst))+              CmmInt 1 _ -> exp `snocOL`+                            (MOVHLPS FF64 r tmp) `snocOL`+                            (MOVD fmt II64 (OpReg tmp) (OpReg dst))+              _          -> panic "Error in offset while unpacking"+      return (Any II64 code)+    vector_int64x2_extract_sse2 _ offset+      = pprPanic "Unsupported offset" (pdoc platform offset)++    vector_int8x16_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register+    vector_int8x16_mul_sse2 expr1 expr2 = do+      -- use two SSE2 PMULLW (low 16 bits of int16 multiplication) operations+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- getSomeReg expr2+      let format = VecFormat 16 FmtInt8+          format16 = VecFormat 8 FmtInt16 -- for PMULLW+      tmp1lo <- getNewRegNat format+      tmp1hi <- getNewRegNat format+      tmp2hi <- getNewRegNat format+      tmp2lo <- getNewRegNat format+      (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate 8 (CmmInt 0xff W16)) -- (0xff,0,0xff,0,...,0xff,0) :: Int8X16+      let code = exp1 `appOL` exp2 `appOL` maskCode `snocOL`+                 (MOVDQU format (OpReg reg1) (OpReg tmp1lo)) `snocOL` -- tmp1lo <- reg1+                 (MOVDQU format (OpReg reg2) (OpReg tmp2lo)) `snocOL` -- tmp2lo <- reg2+                 (PUNPCKLBW format (OpReg reg1) tmp1lo) `snocOL`      -- tmp1lo <- (tmp1lo[0],reg1[0],tmp1lo[1],reg1[1],...,tmp1lo[7],reg1[7]); The first operand does not really matter+                 (PUNPCKLBW format (OpReg reg2) tmp2lo) `snocOL`      -- tmp2lo <- (tmp2lo[0],reg2[0],tmp2lo[1],reg2[1],...,tmp2lo[7],reg2[7]); The first operand does not really matter+                 (MOVDQU format (OpReg reg1) (OpReg tmp1hi)) `snocOL` -- tmp1hi <- reg1+                 (MOVDQU format (OpReg reg2) (OpReg tmp2hi)) `snocOL` -- tmp2hi <- reg2+                 (PUNPCKHBW format (OpReg reg1) tmp1hi) `snocOL`      -- tmp1hi <- (tmp1hi[8],reg1[8],tmp1hi[9],reg1[9],...,tmp1hi[15],reg1[15]); The first operand does not really matter+                 (PMULL format16 (OpReg tmp2lo) tmp1lo) `snocOL`      -- PMULLW; tmp1lo <- (tmp1lo[0]*tmp2lo[0],*,tmp1lo[2]*tmp2lo[2],*,...,tmp1lo[14]*tmp2lo[14],*)+                 (PUNPCKHBW format (OpReg reg2) tmp2hi) `snocOL`      -- tmp2hi <- (tmp2hi[8],reg2[8],tmp2hi[9],reg2[9],...,tmp2hi[15],reg2[15]); The first operand does not really matter+                 (PMULL format16 (OpReg tmp2hi) tmp1hi) `snocOL`      -- PMULLW; tmp1hi <- (tmp1hi[0]*tmp2hi[0],*,tmp1hi[2]*tmp2hi[2],*,...,tmp1hi[14]*tmp2hi[14],*)+                 (PAND format (OpReg maskReg) tmp1lo) `snocOL`        -- tmp1lo <- (tmp1lo[0],0,tmp1lo[2],0,...,tmp1lo[14],0)+                 (PAND format (OpReg maskReg) tmp1hi) `snocOL`        -- tmp1hi <- (tmp1hi[0],0,tmp1hi[2],0,...,tmp1hi[14],0)+                 (PACKUSWB format (OpReg tmp1hi) tmp1lo)              -- tmp1lo <- (tmp1lo[0],tmp1lo[2],...,tmp1lo[14],tmp1hi[0],tmp1hi[2],...tmp1hi[14])+      return (Fixed format tmp1lo code)++    vector_int32x4_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register+    vector_int32x4_mul_sse2 expr1 expr2 = do+      -- use two SSE2 PMULUDQ (int32 x int32 -> int64 multiplication) operations+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- getSomeReg expr2+      let format = VecFormat 4 FmtInt32+      tmpEven <- getNewRegNat format+      tmpOdd1 <- getNewRegNat format+      tmpOdd2 <- getNewRegNat format+      let code dst = exp1 `appOL` exp2 `snocOL`+                     (MOVDQU format (OpReg reg1) (OpReg tmpEven)) `snocOL`                   -- tmpEven <- reg1+                     (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg1) tmpOdd1) `snocOL`    -- tmpOdd1 <- (reg1[1],reg1[1],reg1[3],reg1[3])+                     (PMULUDQ format (OpReg reg2) tmpEven) `snocOL`                          -- tmpEven <- (tmpEven[0]*reg2[0],*,tmpEven[2]*reg2[2],*)+                     (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg2) tmpOdd2) `snocOL`    -- tmpOdd2 <- (reg2[1],reg2[1],reg2[3],reg2[3])+                     (PMULUDQ format (OpReg tmpOdd2) tmpOdd1) `snocOL`                       -- tmpOdd1 <- (tmpOdd1[0]*tmpOdd2[0],*,tmpOdd1[2]*tmpOdd2[2],*)+                     (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpEven) dst) `snocOL`     -- dst <- (tmpEven[0],tmpEven[2],tmpEven[0],tmpEven[0])+                     (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpOdd1) tmpOdd1) `snocOL` -- tmpOdd1 <- (tmpOdd1[0],tmpOdd1[2],tmpOdd1[0],tmpOdd1[0])+                     (PUNPCKLDQ format (OpReg tmpOdd1) dst)                                  -- dst <- (dst[0],tmpOdd1[0],dst[1],tmpOdd1[1])+      return (Any format code)++    -- TODO: We could use `VPMULLQ` if AVX-512 or AVX10.1 is available.+    vector_int64x2_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register+    vector_int64x2_mul_sse2 expr1 expr2 = do+      -- implement 64 bit multiplication using 32-bit PMULUDQ multiplication instructions+      -- (lo1 + shiftL hi1 32) * (lo2 + shiftL hi2 32) = lo1 * lo2 + shiftL (lo1 * hi2) 32 + shiftL (lo2 * hi1) 32+      exp1 <- getAnyReg expr1+      exp2 <- getAnyReg expr2+      let format = VecFormat 2 FmtInt64+      reg1 <- getNewRegNat format+      reg2 <- getNewRegNat format+      tmp1Hi <- getNewRegNat format+      tmp2Hi <- getNewRegNat format+      let code dst = exp1 reg1 `appOL` exp2 reg2 `snocOL`+                     (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL`    -- dst <- reg1+                     (MOVDQU format (OpReg reg1) (OpReg tmp1Hi)) `snocOL` -- tmp1Hi <- reg1+                     (MOVDQU format (OpReg reg2) (OpReg tmp2Hi)) `snocOL` -- tmp2Hi <- reg2+                     (PSRL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL`    -- PSRLQ (logical shift); tmp1Hi <- (tmp1Hi[0] >> 32, tmp1Hi[1] >> 32)+                     (PMULUDQ format (OpReg reg2) dst) `snocOL`           -- dst <- ((dst as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (dst as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64)+                     (PSRL format (OpImm (ImmInt 32)) tmp2Hi) `snocOL`    -- PSRLQ (logical shift); tmp2Hi <- (tmp2Hi[0] >> 32, tmp2Hi[1] >> 32)+                     (PMULUDQ format (OpReg reg2) tmp1Hi) `snocOL`        -- tmp1Hi <- ((tmp1Hi as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (tmp1Hi as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64)+                     (PMULUDQ format (OpReg reg1) tmp2Hi) `snocOL`        -- tmp2Hi <- ((tmp2Hi as Word32X4)[0] * (reg1 as Word32X4)[0] as Word64, (tmp2Hi as Word32X4)[2] * (reg1 as Word32X4)[2] as Word64)+                     (PADD format (OpReg tmp2Hi) tmp1Hi) `snocOL`         -- PADDQ; tmp1Hi <- (tmp1Hi[0] + tmp2Hi[0], tmp1Hi[1] + tmp2Hi[1])+                     (PSLL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL`    -- PSLLQ; tmp1Hi <- (tmp1Hi[0] << 32, tmp1Hi[1] << 32)+                     (PADD format (OpReg tmp1Hi) dst)                     -- PADDQ; dst <- (dst[0] + tmp1Hi[0], dst[1] + tmp1Hi[1])+      return (Any format code)++    vector_int_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_int_minmax_sse minmax l w expr1 expr2 = do+      -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b)+      exp1 <- getAnyReg expr1+      exp2 <- getAnyReg expr2+      let format = case w of+            W8 -> VecFormat l FmtInt8+            W16 -> VecFormat l FmtInt16+            W32 -> VecFormat l FmtInt32+            W64 -> VecFormat l FmtInt64+            _  -> panic "Unsupported width"+      reg1 <- getNewRegNat format+      reg2 <- getNewRegNat format+      tmp <- getNewRegNat format+      let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1+                        (MOVDQU format (OpReg reg2) (OpReg tmp)) `snocOL` -- tmp <- reg2+                        (PCMPGT format (OpReg reg2) dst) `snocOL`         -- dst <- if dst > reg2 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp) `snocOL`            -- tmp <- tmp & dst; if dst then tmp else 0+                        (PANDN format (OpReg reg1) dst) `snocOL`          -- dst <- ~dst & reg1; if dst then 0 else reg1+                        (POR format (OpReg tmp) dst)                      -- dst <- tmp | dst+          codeMax dst = exp1 reg1 `appOL` exp2 reg2 `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1+                        (MOVDQU format (OpReg reg1) (OpReg tmp)) `snocOL` -- tmp <- reg1+                        (PCMPGT format (OpReg reg2) dst) `snocOL`         -- dst <- if dst > reg2 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp) `snocOL`            -- tmp <- tmp & dst; if dst then tmp else 0+                        (PANDN format (OpReg reg2) dst) `snocOL`          -- dst <- ~dst & reg2; if dst then 0 else reg2+                        (POR format (OpReg tmp) dst)                      -- dst <- tmp | dst+      return $ case minmax of+        Min -> Any format codeMin+        Max -> Any format codeMax++    vector_word_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_word_minmax_sse minmax l w expr1 expr2 = do+      -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b)+      -- We can use PCMPGT to compare unsigned integers by flipping the most significant bit.+      exp1 <- getAnyReg expr1+      exp2 <- getAnyReg expr2+      let (format, sign) = case w of+            W8 -> (VecFormat l FmtInt8, 0x80)+            W16 -> (VecFormat l FmtInt16, 0x8000)+            W32 -> (VecFormat l FmtInt32, 2^(31 :: Int))+            W64 -> (VecFormat l FmtInt64, 2^(63 :: Int))+            _  -> panic "Unsupported width"+      reg1 <- getNewRegNat format+      reg2 <- getNewRegNat format+      tmp1 <- getNewRegNat format+      tmp2 <- getNewRegNat format+      (signReg, signCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l (CmmInt sign w))+      let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL`  -- dst <- reg1+                        (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2+                        (MOVDQU format (OpReg reg2) (OpReg tmp2)) `snocOL` -- tmp2 <- reg2+                        (PXOR format (OpReg signReg) dst) `snocOL`         -- dst <- dst ^ 2^(w-1)+                        (PXOR format (OpReg signReg) tmp1) `snocOL`        -- tmp1 < dst ^ 2^(w-1)+                        (PCMPGT format (OpReg tmp1) dst) `snocOL`          -- dst <- if dst > tmp1 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp2) `snocOL`            -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0+                        (PANDN format (OpReg reg1) dst) `snocOL`           -- dst <- ~dst & reg1; if dst then 0 else reg1+                        (POR format (OpReg tmp2) dst)                      -- dst <- tmp2 | dst+          codeMax dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL`  -- dst <- reg1+                        (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2+                        (MOVDQU format (OpReg reg1) (OpReg tmp2)) `snocOL` -- tmp2 <- reg1+                        (PXOR format (OpReg signReg) dst) `snocOL`         -- dst <- dst ^ 2^(w-1)+                        (PXOR format (OpReg signReg) tmp1) `snocOL`        -- tmp1 <- tmp1 ^ 2^(w-1)+                        (PCMPGT format (OpReg tmp1) dst) `snocOL`          -- dst <- if dst > tmp1 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp2) `snocOL`            -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0+                        (PANDN format (OpReg reg2) dst) `snocOL`           -- dst <- ~dst & reg2; if dst then 0 else reg2+                        (POR format (OpReg tmp2) dst)                      -- dst <- tmp2 | dst+      return $ case minmax of+        Min -> Any format codeMin+        Max -> Any format codeMax++    vector_shuffle_floatx4_sse :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_floatx4_sse sse4_1 v1 v2 is+      | length is == 4, all (\i -> 0 <= i && i < 8) is = do+        let fmt = VecFormat 4 FmtFloat++            -- A helper function to shuffle a vector `r` in-place using (dst,src) pairs+            -- (r[d0],r[d1],...) <- (r[s0],r[s1],...)+            inplaceShuffle pairs r = do+              let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs+              case mask of+                0b11_10_01_00 -> nilOL -- trivial+                0b01_00_01_00 -> unitOL (MOVLHPS fmt r r)+                0b11_10_11_10 -> unitOL (MOVHLPS fmt r r)+                0b01_01_00_00 -> unitOL (UNPCKL fmt (OpReg r) r)+                0b11_11_10_10 -> unitOL (UNPCKH fmt (OpReg r) r)+                _ -> unitOL (SHUF fmt (ImmInt mask) (OpReg r) r)++            -- All elements are from one source vector+            oneSource p0 p1 p2 p3 v = do+              exp <- getAnyReg v+              let code dst = exp dst `appOL`+                             inplaceShuffle [p0,p1,p2,p3] dst+              return $ Any fmt code++            -- Two elements from one vector, other two from the other vector+            twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v1 v2+            twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v2 v1+            twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v1 v2+            twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v2 v1+            twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_op_sse UNPCKL fmt v1 v2+            twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_op_sse UNPCKL fmt v2 v1+            twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_op_sse UNPCKH fmt v1 v2+            twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_op_sse UNPCKH fmt v2 v1+            twoAndTwo p0 p1 q0 q1 v1 v2 =+              if sse4_1 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then+                let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1)+                in vector_op_sse (`BLEND` (ImmInt imm)) fmt v1 v2+              else do+                let imm = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6)+                reg <- vector_op_sse (`SHUF` (ImmInt imm)) fmt v1 v2+                exp <- anyReg reg+                let code dst = exp dst `appOL`+                               inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst+                return $ Any fmt code++            -- Three elements from one vector, the last one from the other vector+            threeAndOne p0 p1 p2 q0 v1 v2+              | sse4_1 = do -- Use INSERTPS+                exp1 <- getAnyReg v1+                (r2, exp2) <- getSomeReg v2+                let imm2 = (snd q0 `shiftL` 6) .|. (fst q0 `shiftL` 4)+                dst <- getNewRegNat fmt+                let code = exp1 dst `appOL` exp2 `appOL`+                           inplaceShuffle [p0,p1,p2,(fst q0,fst q0)] dst `snocOL`+                           (INSERTPS fmt (ImmInt imm2) (OpReg r2) dst)+                return $ Fixed fmt dst code++              | (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use MOVSS+                exp1 <- getAnyReg v1+                (r2, exp2) <- getSomeReg v2+                dst <- getNewRegNat fmt+                let code = exp1 dst `appOL` exp2 `snocOL`+                           (MOV fmt (OpReg r2) (OpReg dst)) `appOL`+                           inplaceShuffle [p0,p1,p2,(fst q0,0)] dst+                return $ Fixed fmt dst code++              | otherwise = do -- Use two or three SHUFPSs+                (r1, exp1) <- getSomeReg v1+                exp2 <- getAnyReg v2+                let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6)+                let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0)+                    (imm2, pairs) =+                      if fst q0 == 1 then+                        (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                      else+                        (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                dst <- getNewRegNat fmt+                let code = exp1 `appOL` exp2 dst `snocOL`+                           (SHUF fmt (ImmInt imm1) (OpReg r1) dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0])+                           (SHUF fmt (ImmInt imm2) (OpReg r1) dst) `appOL`+                           inplaceShuffle pairs dst+                return $ Fixed fmt dst code++        -- We partition the list of indices into those that refer to the first vector and those that+        -- refer to the second, and handle each case depending on the number of indices in each group.+        let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is)+        case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of+          ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1+          ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2+          ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2+          ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1+          ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2+          _ -> pprPanic "vector shuffle: cannot occur" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is)++    -- Shuffle with AVX instructions.+    -- The components above 128 bits are shuffled in the same way as the lower 128 bits.+    -- For example, `l == 8 && is == [0,2,5,7]` would represent `shuffleFloatX8# _ _ (# 0#, 2#, 9#, 11#, 4#, 6#, 13#, 15# #)`.+    vector_shuffle_float_avx :: Length -- Vector length. 4 for XMM, 8 for YMM, 16 for ZMM.+                             -> CmmExpr+                             -> CmmExpr+                             -> [Int] -- 4-element list of indices+                             -> NatM Register+    vector_shuffle_float_avx l v1 v2 is+      | length is == 4, all (\i -> 0 <= i && i < 8) is = do+        let fmt = VecFormat l FmtFloat++            -- A helper function to shuffle a vector using (dst,src) pairs+            -- (dst[d0],dst[d1],...) <- (r[s0],r[s1],...)+            inplaceShuffle pairs r dst = do+              let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs+              case mask of+                0b11_10_01_00 | r == dst -> nilOL+                              | otherwise -> unitOL (VMOVU fmt (OpReg r) (OpReg dst)) -- trivial+                0b01_00_01_00 | l == 4 -> unitOL (VMOVLHPS fmt r r dst) -- 128-bit only+                0b11_10_11_10 | l == 4 -> unitOL (VMOVHLPS fmt r r dst) -- 128-bit only+                0b01_01_00_00 -> unitOL (VUNPCKL fmt (OpReg r) r dst)+                0b11_11_10_10 -> unitOL (VUNPCKH fmt (OpReg r) r dst)+                _ -> unitOL (VSHUF fmt (ImmInt mask) (OpReg r) r dst)++            -- All elements are from one source vector+            oneSource p0 p1 p2 p3 v = do+              (r, exp) <- getSomeReg v+              let code dst = exp `appOL`+                             inplaceShuffle [p0,p1,p2,p3] r dst+              return $ Any fmt code++            -- Two elements from one vector, other two from the other vector+            twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v1 v2+            twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v2 v1+            twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v1 v2+            twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v2 v1+            twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v1 v2+            twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v2 v1+            twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v1 v2+            twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v2 v1+            twoAndTwo p0 p1 q0 q1 v1 v2 =+              if l <= 8 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then+                -- VBLENDPS does not support ZMM (no EVEX-encoded variant)+                let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1)+                    imm' = if l == 4 then imm .|. (imm `shiftL` 4) else imm+                in vector_float_op_avx (`VBLEND` (ImmInt imm')) l W32 v1 v2+              else do+                let imm1 = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6)+                reg <- vector_float_op_avx (`VSHUF` (ImmInt imm1)) l W32 v1 v2+                exp <- anyReg reg+                let code dst = exp dst `appOL`+                               inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst dst+                return $ Any fmt code++            -- Three elements from one vector, the last one from the other vector+            threeAndOne p0 p1 p2 q0 v1 v2+              | l == 4, (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use VMOVSS (128-bit only)+                (r1, exp1) <- getSomeReg v1+                (r2, exp2) <- getSomeReg v2+                let code dst = exp1 `appOL` exp2 `snocOL`+                               (VMOV_MERGE fmt r2 r1 dst) `appOL`+                               inplaceShuffle [p0,p1,p2,(fst q0,0)] dst dst+                return $ Any fmt code++              | l == 4 = do -- Use VINSERTPS (128-bit only)+                (r1, exp1) <- getSomeReg v1+                (r2, exp2) <- getSomeReg v2+                let i = case [0, 1, 2, 3] \\ [snd p0, snd p1, snd p2] of+                          i:_ -> i -- We can clobber this position of r1+                          _ -> panic "cannot occur"+                    imm = (snd q0 `shiftL` 6) .|. (i `shiftL` 4)+                    code dst = exp1 `appOL` exp2 `snocOL`+                               (VINSERTPS fmt (ImmInt imm) (OpReg r2) r1 dst) `appOL`+                               inplaceShuffle [p0,p1,p2,(fst q0,i)] dst dst+                return $ Any fmt code++              | otherwise = do -- Use two or three VSHUFPSs+                (r1, exp1) <- getSomeReg v1+                exp2 <- getAnyReg v2+                let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6)+                let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0)+                    (imm2, pairs) =+                      if fst q0 == 1 then+                        (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                      else+                        (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                dst <- getNewRegNat fmt+                let code = exp1 `appOL` exp2 dst `snocOL`+                           (VSHUF fmt (ImmInt imm1) (OpReg r1) dst dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0])+                           (VSHUF fmt (ImmInt imm2) (OpReg r1) dst dst) `appOL`+                           inplaceShuffle pairs dst dst+                return $ Fixed fmt dst code++        -- We partition the list of indices into those that refer to the first vector and those that+        -- refer to the second, and handle each case depending on the number of indices in each group.+        let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is)+        case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of+          ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1+          ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2+          ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2+          ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1+          ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2+          _ -> pprPanic "vector shuffle: cannot occur" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is)++    vector_shuffle_doublex2_sse :: CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_doublex2_sse v1 v2 is+      | [i0, i1] <- is =+        let fmt = VecFormat 2 FmtDouble+        in case (i0, i1) of+          -- Trivial cases+          (0, 1) -> getRegister' platform is32Bit v1+          (2, 3) -> getRegister' platform is32Bit v2++          -- MOVSD/UNPCKLPD/UNPCKHPD have shorter encoding than SHUFPD+          -- If SSE4.1 is available, BLENDPD could also be used in place of MOVSD (the encoding is longer though)+          (0, 3) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v2 v1 -- MOVSD+          (2, 1) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v1 v2 -- MOVSD+          _ | i0 == i1 -> do+            exp <- getAnyReg (if i0 <= 1 then v1 else v2)+            let unpck = if i0 == 0 || i0 == 2+                        then UNPCKL+                        else UNPCKH+                code dst = exp dst `snocOL`+                           (unpck fmt (OpReg dst) dst)+            return (Any fmt code)+          (0, 2) -> vector_op_sse UNPCKL fmt v1 v2+          (2, 0) -> vector_op_sse UNPCKL fmt v2 v1+          (1, 3) -> vector_op_sse UNPCKH fmt v1 v2+          (3, 1) -> vector_op_sse UNPCKH fmt v2 v1++          -- SHUFPD+          (1, 2) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v1 v2+          (3, 0) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v2 v1+          (1, 0) -> do+            exp <- getAnyReg v1+            let code dst = exp dst `snocOL`+                           (SHUF fmt (ImmInt 0b01) (OpReg dst) dst)+            return (Any fmt code)+          (3, 2) -> do+            exp <- getAnyReg v2+            let code dst = exp dst `snocOL`+                           (SHUF fmt (ImmInt 0b01) (OpReg dst) dst)+            return (Any fmt code)+          _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)++    -- Shuffle with AVX instructions.+    -- The components above 128 bits are shuffled in the same way as the lower 128 bits.+    -- For example, `l == 4 && is == [0,3]` would represent `shuffleDoubleX4# _ _ (# 0#, 5#, 2#, 7# #)`.+    vector_shuffle_double_avx :: Length -- Vector length. 2 for XMM, 4 for YMM, 8 for ZMM.+                              -> CmmExpr+                              -> CmmExpr+                              -> [Int] -- 2-element list of indices+                              -> NatM Register+    vector_shuffle_double_avx l v1 v2 is+      | [i0, i1] <- is =+        let fmt = VecFormat l FmtDouble+            repeatShufpdMask m = case l of+              8 -> m .|. (m `shiftL` 2) .|. (m `shiftL` 4) .|. (m `shiftL` 6)+              4 -> m .|. (m `shiftL` 2)+              _ -> m+        in case (i0, i1) of+          -- Trivial cases+          (0, 1) -> getRegister' platform is32Bit v1+          (2, 3) -> getRegister' platform is32Bit v2++          -- VMOVSD/VUNPCKLPD/VUNPCKHPD have shorter encoding than VSHUFPD+          (0, 3) | l == 2 -> do+                   (r1, exp1) <- getSomeReg v1+                   (r2, exp2) <- getSomeReg v2+                   let code dst = exp1 `appOL` exp2 `snocOL`+                                  (VMOV_MERGE fmt r1 r2 dst) -- VMOVSD+                   return (Any fmt code)+                 | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v1 v2+          (2, 1) | l == 2 -> do+                   (r1, exp1) <- getSomeReg v1+                   (r2, exp2) <- getSomeReg v2+                   let code dst = exp1 `appOL` exp2 `snocOL`+                                  (VMOV_MERGE fmt r2 r1 dst) -- VMOVSD+                   return (Any fmt code)+                 | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v2 v1+          _ | i0 == i1 -> do+            (r, exp) <- getSomeReg (if i0 <= 1 then v1 else v2)+            let unpck = if i0 == 0 || i0 == 2+                        then VUNPCKL+                        else VUNPCKH+                code dst = exp `snocOL`+                           (unpck fmt (OpReg r) r dst)+            return (Any fmt code)+          (0, 2) -> vector_float_op_avx VUNPCKL l W64 v1 v2+          (2, 0) -> vector_float_op_avx VUNPCKL l W64 v2 v1+          (1, 3) -> vector_float_op_avx VUNPCKH l W64 v1 v2+          (3, 1) -> vector_float_op_avx VUNPCKH l W64 v2 v1++          -- SHUFPD+          (1, 2) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v1 v2+          (3, 0) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v2 v1+          (1, 0) -> do+            (r, exp) <- getSomeReg v1+            let code dst = exp `snocOL`+                           (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst)+            return (Any fmt code)+          (3, 2) -> do+            (r, exp) <- getSomeReg v2+            let code dst = exp `snocOL`+                           (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst)+            return (Any fmt code)+          _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)++    isZeroVecLit :: CmmExpr -> Bool+    isZeroVecLit (CmmLit (CmmVec elems)) = all (\lit -> case lit of CmmInt 0 _ -> True; _ -> False) elems+    isZeroVecLit _ = False++    vector_shuffle_int128_common :: Bool -> Format -> CmmExpr -> CmmExpr -> [Int] -> Maybe (NatM Register)+    vector_shuffle_int128_common sse4_1 fmt v1 v2 is+      | length is == n, all (\i -> 0 <= i && i < 2 * n) is = if+        -- Trivial cases+        | is == [0..n-1] -> Just $ getRegister' platform is32Bit v1+        | is == [n..2*n-1] -> Just $ getRegister' platform is32Bit v2++        -- We would like to emit PXOR for these trivial cases, instead of PSLLDQ.+        -- These conditions can be generalized to the cases where all elements are equal,+        -- or more generally, a constant-folding rule.+        | v1IsZero, all (< n) is -> Just $ getRegister' platform is32Bit v1+        | v2IsZero, all (>= n) is -> Just $ getRegister' platform is32Bit v2++        -- PSLLDQ: v2 == 0 && is == [n..(2n-1),...,n..(2n-1);0,1,2,3,...,n-i-1]+        | v2IsZero, (z, js) <- span (>= n) is, and (zipWith (==) js [0..]) -> Just $ do+          exp1 <- getAnyReg v1+          let code dst = exp1 dst `snocOL`+                         (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PSLLDQ: v1 == 0 && is == [0..(n-1),...,0..(n-1);n,n+1,...,2n-i-1]+        | v1IsZero, (z, js) <- span (< n) is, and (zipWith (==) js [n..]) -> Just $ do+          exp2 <- getAnyReg v2+          let code dst = exp2 dst `snocOL`+                         (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PSRLDQ: v2 == 0 && is == [i,i+1,...,n-2,n-1;n..(2n-1),...,n..(2n-1)]+        | v2IsZero, (js, z) <- span (< n) is, all (>= n) z, and (zipWith (==) (reverse js) [n-1,n-2..]) -> Just $ do+          exp1 <- getAnyReg v1+          let code dst = exp1 dst `snocOL`+                         (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PSRLDQ: v1 == 0 && is == [n+i,...,2n-2,2n-1;0..(n-1),...,0..(n-1)]+        | v1IsZero, (js, z) <- span (>= n) is, all (< n) z, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]) -> Just $ do+          exp2 <- getAnyReg v2+          let code dst = exp2 dst `snocOL`+                         (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [i,i+1,...,n-2,n-1;n,n+1,...,n+i-1]+        | (js, ks) <- span (< n) is, and (zipWith (==) (reverse js) [n-1,n-2..]), and (zipWith (==) ks [n..]) -> Just $ do+          ssse3 <- ssse3Enabled+          let amountInBytes = widthInBytes * length ks+          if ssse3+            then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v2 v1+            else do+              exp1 <- getAnyReg v1+              exp2 <- getAnyReg v2+              tmp <- getNewRegNat fmt+              let code dst = exp1 tmp `snocOL`+                             (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL`+                             exp2 dst `snocOL`+                             (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL`+                             (POR fmt (OpReg tmp) dst)+              return (Any fmt code)++        -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [n+i,n+i+1,...,2n-2,2n-1;0,1,...,i-1]+        | (js, ks) <- span (>= n) is, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]), and (zipWith (==) ks [0..]) -> Just $ do+          ssse3 <- ssse3Enabled+          let amountInBytes = widthInBytes * length ks+          if ssse3+            then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v1 v2+            else do+              exp1 <- getAnyReg v1+              exp2 <- getAnyReg v2+              tmp <- getNewRegNat fmt+              let code dst = exp2 tmp `snocOL`+                             (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL`+                             exp1 dst `snocOL`+                             (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL`+                             (POR fmt (OpReg tmp) dst)+              return (Any fmt code)++        -- PBLENDW (SSE4.1): map (`mod` n) is == [0,1,...,n-1] if widthInBytes >= 2+        | sse4_1, widthInBytes >= 2, and (zipWith (\i j -> i `rem` n == j) is [0..]) -> Just $ do+          let k = widthInBytes `quot` 2+              m = bit k - 1+              imm = foldr (\i acc -> if i >= n then (acc `shiftL` k) .|. m else acc `shiftL` k) 0 is+          vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2++        | otherwise -> Nothing++      | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is)+      where+        (n, widthInBytes) = case fmt of+          VecFormat 16 FmtInt8 -> (16, 1)+          VecFormat 8 FmtInt16 -> (8, 2)+          VecFormat 4 FmtInt32 -> (4, 4)+          VecFormat 2 FmtInt64 -> (2, 8)+          _ -> pprPanic "Invalid format" (ppr fmt)+        v1IsZero = isZeroVecLit v1+        v2IsZero = isZeroVecLit v2++    vector_shuffle_int8x16 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int8x16 sse4_1 v1 v2 is+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = do+        ssse3 <- ssse3Enabled+        let fmtInt16X8 = VecFormat 8 FmtInt16+            v1IsZero = isZeroVecLit v1+            v2IsZero = isZeroVecLit v2+            tryInt16X8Mask [] = Just []+            tryInt16X8Mask (j0:j1:js)+              | even j0, j1 == j0 + 1 = (j0 `quot` 2 :) <$> tryInt16X8Mask js+            tryInt16X8Mask _ = Nothing+        if+          -- PUNPCKLBW / PUNPCKHBW+          | [0,16,1,17,2,18,3,19,4,20,5,21,6,22,7,23] <- is -> vector_op_sse PUNPCKLBW fmt v1 v2+          | [16,0,17,1,18,2,19,3,20,4,21,5,22,6,23,7] <- is -> vector_op_sse PUNPCKLBW fmt v2 v1+          | [8,24,9,25,10,26,11,27,12,28,13,29,14,30,15,31] <- is -> vector_op_sse PUNPCKHBW fmt v1 v2+          | [24,8,25,9,26,10,27,11,28,12,29,13,30,14,31,15] <- is -> vector_op_sse PUNPCKHBW fmt v2 v1++          -- PSHUFB (SSSE3)+          | ssse3, all (< 16) is || v2IsZero -> do+            exp1 <- getAnyReg v1+            let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is+            Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1+            let code dst = exp1 dst `appOL`+                           amode_code1 `snocOL`+                           (PSHUFB fmt (OpAddr amode1) dst)+            return (Any fmt code)++          -- PSHUFB (SSSE3)+          | ssse3, all (>= 16) is || v1IsZero -> do+            exp2 <- getAnyReg v2+            let mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is+            Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2+            let code dst = exp2 dst `appOL`+                           amode_code2 `snocOL`+                           (PSHUFB fmt (OpAddr amode2) dst)+            return (Any fmt code)++          -- PBLENDW (SSE4.1): js <- tryInt16X8Mask is, map (`mod` 8) js == [0,1,...,7]+          | sse4_1, Just js <- tryInt16X8Mask is, and (zipWith (\i j -> i `rem` 8 == j) js [0..]) -> do+            let imm = foldr (\i acc -> if i >= 8 then (acc `shiftL` 1) .|. 1 else acc `shiftL` 1) 0 js+            vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2++          -- General case with SSSE3: PSHUFB + PSHUFB + POR+          | ssse3 -> do+            exp1 <- getAnyReg v1+            exp2 <- getAnyReg v2+            tmp1 <- getNewRegNat fmt+            let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is+                mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is+            Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1+            Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2+            let code dst = exp1 tmp1 `appOL` exp2 dst `appOL`+                           amode_code1 `snocOL`+                           (PSHUFB fmt (OpAddr amode1) tmp1) `appOL`+                           amode_code2 `snocOL`+                           (PSHUFB fmt (OpAddr amode2) dst) `snocOL`+                           (POR fmt (OpReg tmp1) dst)+            return (Any fmt code)++          -- General case with SSE2: GPR + MOVQ + PUNPCKLQDQ+          | otherwise -> do+            (r1, exp1) <- getSomeReg v1+            (r2, exp2) <- getSomeReg v2+            tmp <- getNewRegNat II64+            tmpLo <- getNewRegNat II64+            tmpHi <- getNewRegNat II64+            tmpXmm <- getNewRegNat fmt+            dst <- getNewRegNat fmt+            let place8Bits srcPos dstPos dst =+                  -- Assumption: 0 <= srcPos < 32, 0 <= dstPos < 8+                  -- tmp <- (src[srcPos] `shiftR` ((srcPos `rem` 16) * 8)) .&. 0xff+                  -- dst <- dst .|. (tmp `shiftL` (dstPos * 8))+                  let r = if srcPos < 16 then r1 else r2+                  in case (srcPos `rem` 16) `quotRem` 2 of+                      (k, 0) -> toOL [ PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp)+                                     , MOVZxL II8 (OpReg tmp) (OpReg tmp)+                                     , SHL II64 (OpImm (ImmInt (8 * dstPos))) (OpReg tmp)+                                     , OR II64 (OpReg tmp) (OpReg dst)+                                     ]+                      (k, _) -> (PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp)) `consOL`+                                ((case dstPos of+                                    0 -> unitOL (SHR II32 (OpImm (ImmInt 8)) (OpReg tmp))+                                    1 -> unitOL (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp))+                                    _ -> toOL [ AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)+                                              , SHL II64 (OpImm (ImmInt (8 * (dstPos - 1)))) (OpReg tmp) ]) `snocOL`+                                 (OR II64 (OpReg tmp) (OpReg dst)))+                makeInt8x8OnGPR dst js = (XOR II32 (OpReg dst) (OpReg dst)) `consOL`+                                         concatOL [ place8Bits srcPos dstPos dst | (srcPos, dstPos) <- zip js [0..] ]+                code = exp1 `appOL` exp2 `appOL`+                       makeInt8x8OnGPR tmpLo (take 8 is) `snocOL`+                       (MOVD II64 fmt (OpReg tmpLo) (OpReg dst)) `appOL`+                       makeInt8x8OnGPR tmpHi (drop 8 is) `snocOL`+                       (MOVD II64 fmt (OpReg tmpHi) (OpReg tmpXmm)) `snocOL`+                       (PUNPCKLQDQ fmt (OpReg tmpXmm) dst)+            return (Fixed fmt dst code)+      where fmt = VecFormat 16 FmtInt8++    vector_shuffle_int16x8 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int16x8 sse4_1 v1 v2 is@(i0:i1:i2:i3:i4567@[i4,i5,i6,i7])+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = do+        (r1, exp1) <- getSomeReg v1+        (r2, exp2) <- getSomeReg v2+        let -- shufL src dst k0 k1 k2 k3 (0 <= k_i < 4):+            --   dst <- (src[k0],src[k1],src[k2],src[k3],src[4],src[5],src[6],src[7])+            shufL src dst 0 1 2 3 | src == dst = nilOL+                                  | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+            shufL src dst k0 k1 k2 k3 = let imm = k0 + (k1 `shiftL` 2) + (k2 `shiftL` 4) + (k3 `shiftL` 6)+                                        in unitOL (PSHUFLW fmt (ImmInt imm) (OpReg src) dst)+            -- shufH src dst k0 k1 k2 k3 (4 <= k_i < 8):+            --   dst <- (src[0],src[1],src[2],src[3],src[k0],src[k1],src[k2],src[k3])+            shufH src dst 4 5 6 7 | src == dst = nilOL+                                  | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+            shufH src dst k0 k1 k2 k3 = let imm = (k0 - 4) + ((k1 - 4) `shiftL` 2) + ((k2 - 4) `shiftL` 4) + ((k3 - 4) `shiftL` 6)+                                        in unitOL (PSHUFHW fmt (ImmInt imm) (OpReg src) dst)++            shufLHImm src dst immLo immHi = case (immLo, immHi) of+              (0b11_10_01_00, 0b11_10_01_00)+                | src == dst -> nilOL+                | otherwise -> unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+              (0b11_10_01_00, _) -> unitOL (PSHUFHW fmt (ImmInt immHi) (OpReg src) dst)+              (_, 0b11_10_01_00) -> unitOL (PSHUFLW fmt (ImmInt immLo) (OpReg src) dst)+              (_, _) -> toOL [PSHUFLW fmt (ImmInt immLo) (OpReg src) dst,+                              PSHUFHW fmt (ImmInt immHi) (OpReg dst) dst]++            -- ks = [k0,...,k7]+            -- Assumption: 0 <= k_i < 4 for 0 <= i < 4, 4 <= k_i < 8 for 4 <= i < 8+            -- dst <- (src[k0],...,src[k7])+            shufLH src dst ks+              = let (k_lo, k_hi) = splitAt 4 ks+                    immLo = foldr (\k acc -> (acc `shiftL` 2) + k) 0 k_lo+                    immHi = foldr (\k acc -> (acc `shiftL` 2) + (k - 4)) 0 k_hi+                in shufLHImm src dst immLo immHi++            -- shufRev src dst j0 j1 j2 j3 j4 j5 j6 j7:+            -- Assumption: [j0,j1,j2,j3] `elem` permutations [0,1,2,3] && [j4,j5,j6,j7] `elem` permutations [4,5,6,7]:+            --   dst[j0] <- src[0]; dst[j1] <- src[1]; dst[j2] <- src[2]; dst[j3] <- src[3];+            --   dst[j4] <- src[4]; dst[j5] <- src[5]; dst[j6] <- src[6]; dst[j7] <- src[7];+            shufRev src dst _j0 j1 j2 j3 _j4 j5 j6 j7+              = let immLo = (1 `shiftL` (2 * j1)) + (2 `shiftL` (2 * j2)) + (3 `shiftL` (2 * j3))+                    immHi = (1 `shiftL` (2 * (j5 - 4))) + (2 `shiftL` (2 * (j6 - 4))) + (3 `shiftL` (2 * (j7 - 4)))+                in shufLHImm src dst immLo immHi+            i0123 = [i0, i1, i2, i3]+        if+          -- PSHUFLW + PSHUFHW+          | all (\i -> i < 4) i0123+          , all (\i -> 4 <= i && i < 8) i4567+          -> do+            let code dst = exp1 `appOL`+                           shufLH r1 dst is+            return (Any fmt code)++          -- PSHUFLW + PSHUFHW+          | all (\i -> 8 <= i && i < 12) i0123+          , all (\i -> 12 <= i) i4567+          -> do+            let code dst = exp2 `appOL`+                           shufLH r2 dst (map (subtract 8) is)+            return (Any fmt code)++          -- PSHUF{L,H}W + PBLENDW (SSE4.1)+          | sse4_1+          , all (\i -> i `rem` 8 < 4) i0123+          , all (\i -> 4 <= i `rem` 8) i4567+          -> do+            tmp <- getNewRegNat fmt+            let imm = foldl' (\acc (i,p) -> if i >= 8 then setBit acc p else acc) 0 (zip is [0..])+                js = zipWith (\i p -> if i >= 8 then p else i) is [0..]+                ks = zipWith (\i p -> if i >= 8 then i - 8 else p) is [0..]+                code dst = exp1 `appOL` exp2 `appOL`+                           shufLH r2 tmp ks `appOL`+                           shufLH r1 dst js `snocOL`+                           (PBLENDW fmt (ImmInt imm) (OpReg tmp) dst)+            return (Any fmt code)++          -- PSHUFLW + PSHUFLW + PUNPCKLWD + PSHUFLW + PSHUFHW+          | all (\i -> i < 4 || (8 <= i && i < 12)) is+          , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 4) [(0, i0), (1, i1), (2, i2), (3, i3)]+          , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 4) [(4, i4), (5, i5), (6, i6), (7, i7)]+          -> do+            tmp1 <- getNewRegNat fmt+            tmp2 <- getNewRegNat fmt+            let code dst = exp1 `appOL` exp2 `appOL`+                           shufL r1 tmp1 k0 k1 k4 k5 `appOL`+                           shufL r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL`+                           (PUNPCKLWD fmt (OpReg tmp2) tmp1) `appOL`+                           shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7+            return (Any fmt code)++          -- PSHUFHW + PSHUFHW + PUNPCKHWD + PSHUFLW + PSHUFHW+          | all (\i -> (4 <= i && i < 8) || 12 <= i) is+          , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 8) [(0, i0), (1, i1), (2, i2), (3, i3)]+          , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 8) [(4, i4), (5, i5), (6, i6), (7, i7)]+          -> do+            tmp1 <- getNewRegNat fmt+            tmp2 <- getNewRegNat fmt+            let code dst = exp1 `appOL` exp2 `appOL`+                           shufH r1 tmp1 k0 k1 k4 k5 `appOL`+                           shufH r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL`+                           (PUNPCKHWD fmt (OpReg tmp2) tmp1) `appOL`+                           shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7+            return (Any fmt code)++          -- Generic implementation+          | otherwise -> do+            tmp0 <- getNewRegNat II32+            tmps <- replicateM 7 (getNewRegNat II32)+            let code dst = exp1 `appOL` exp2 `appOL`+                           toOL [ PEXTR II32 fmt (ImmInt i') r (OpReg tmp)+                                | (i, tmp) <- zip is (tmp0:tmps)+                                , let (i', r) = if i < 8 then (i, r1) else (i - 8, r2)+                                ] `snocOL`+                           (MOVD II32 fmt (OpReg tmp0) (OpReg dst)) `appOL`+                           toOL [ PINSR II32 fmt (ImmInt i) (OpReg tmp) dst+                                | (i, tmp) <- zip [1..] tmps+                                ]+            return (Any fmt code)+      where fmt = VecFormat 8 FmtInt16+    vector_shuffle_int16x8 _ _ _ is = pprPanic "vector shuffle: wrong number of indices (expected 8)" (ppr is)++    vector_shuffle_int32x4 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int32x4 sse4_1 v1 v2 is+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = do+        let -- `pshufd imm src dst` is equivalent to `PSHUFD fmt (ImmInt imm) (OpReg src) dst`+            pshufd 0b11_10_01_00 src dst+              | src == dst = nilOL+              | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+            pshufd imm src dst = unitOL (PSHUFD fmt (ImmInt imm) (OpReg src) dst)++            -- PSHUFD (composeImm imm1 imm2) src dst == (PSHUFD imm1 src tmp; PSHUFD imm2 tmp dst)+            composeMask :: Int -> Int -> Int+            composeMask imm1 imm2 = foldr (\i acc -> let j = (imm2 `shiftR` (2 * i)) .&. 3+                                                     in (imm1 `shiftR` (2 * j) .&. 3) .|. (acc `shiftL` 2)+                                          ) 0 [0..3]++            makeMask :: [(Int, Int)] -- List of (dst,src). If src == -1, the value there can be anything.+                     -> Int+            makeMask m = foldl' (.|.) 0 [ src `shiftL` (2 * dst) | dst <- [0..3], let src = fromMaybe dst (mfilter (>= 0) $ lookup dst m) ]++            twoAndTwo p0@(1,_) p1@(3,_) q0@(0,_) q1@(2,_) imm4 v1 v2 = twoAndTwo' q0 q1 p0 p1 imm4 v2 v1+            twoAndTwo p0 p1 q0 q1 imm4 v1 v2 = twoAndTwo' p0 p1 q0 q1 imm4 v1 v2+            twoAndTwo' p0 p1 q0 q1 imm4 v1 v2 = do+              (r1, exp1) <- getSomeReg v1+              (r2, exp2) <- getSomeReg v2+              tmp <- getNewRegNat fmt+              let (instr, imm1, imm2) =+                    if all (\(_,i) -> 2 <= i || i == -1) [p0,p1,q0,q1] then+                      -- The inputs are all from higher lanes+                      (PUNPCKHDQ, makeMask [(2,snd p0),(3,snd p1)], makeMask [(2,snd q0),(3,snd q1)])+                    else+                      (PUNPCKLDQ, makeMask [(0,snd p0),(1,snd p1)], makeMask [(0,snd q0),(1,snd q1)])+                  imm3 = makeMask [(fst p0,0),(fst q0,1),(fst p1,2),(fst q1,3)]+                  code dst = exp1 `appOL` exp2 `appOL`+                             pshufd imm2 r2 tmp `appOL`             -- tmp <- (*,*,r2[snd q0],r2[snd q1]) or (r2[snd q0],r2[snd q1],*,*)+                             pshufd imm1 r1 dst `snocOL`            -- dst <- (*,*,r1[snd p0],r1[snd p1]) or (r1[snd p0],r1[snd p1],*,*)+                             instr fmt (OpReg tmp) dst `appOL`      -- dst <- (dst[0],tmp[0],dst[1],tmp[1]) = (r1[snd p0],r2[snd q0],r1[snd p1],r2[snd q1])+                             pshufd (composeMask imm3 imm4) dst dst -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst q1]) <- dst+              return $ Any fmt code++            threeAndOne p0 p1 p2 q0+              | snd p0 == snd p1 = twoAndTwo p0 p2 q0 (fst p1,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p0),(fst p2,fst p2),(fst q0,fst q0)])+              | snd p0 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p0),(fst q0,fst q0)])+              | snd p1 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p1),(fst q0,fst q0)])+              | otherwise = \v1 v2 -> do+                (r1, exp1) <- getSomeReg v1+                (r2, exp2) <- getSomeReg v2+                tmp1 <- getNewRegNat fmt+                if sse4_1+                  then do+                    let imm1 = makeMask [p0,p1,p2]+                        imm2 = makeMask [q0]+                        imm3 = foldl' (.|.) 0 [ (if i == fst q0 then 0 else 3) `shiftL` (2 * i) | i <- [0..3] ]+                    let code dst = exp1 `appOL` exp2 `appOL`+                                   pshufd imm1 r1 tmp1 `appOL`+                                   pshufd imm2 r2 dst `snocOL`+                                   PBLENDW fmt (ImmInt imm3) (OpReg tmp1) dst+                    return $ Any fmt code+                  else do+                    tmp2 <- getNewRegNat fmt+                    tmp3 <- getNewRegNat fmt+                    let imm1 = snd q0 .|. 0b11_10_01_00+                        imm2 = snd p1 .|. 0b11_10_01_00+                        imm3 = snd p0 .|. (snd p2 `shiftL` 2) .|. 0b11_10_00_00+                        imm6 = makeMask [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)]+                        code dst = exp1 `appOL` exp2 `appOL`+                                   pshufd imm1 r2 tmp1 `appOL`              -- tmp1 <- (y0,*,*,*)+                                   pshufd imm2 r1 tmp2 `appOL`              -- tmp2 <- (x1,*,*,*)+                                   pshufd imm3 r1 tmp3 `snocOL`             -- tmp3 <- (x0,x2,*,*)+                                   PUNPCKLDQ fmt (OpReg tmp2) tmp1 `snocOL` -- tmp1 <- unpckldq tmp1 tmp2 = (y0,x1,*,*)+                                   PUNPCKLDQ fmt (OpReg tmp3) tmp1 `appOL`  -- tmp1 <- unpckldq tmp1 tmp3 = (y0,x0,x1,x2)+                                   pshufd imm6 tmp1 dst                     -- dst <- shuffle tmp1+                    return $ Any fmt code++        let (from_first, from_second) = partition (\(_dstPos,srcPos) -> srcPos < 4) (zip [0..] is)+        case (from_first, map (\(dstPos,srcPos) -> (dstPos, srcPos - 4)) from_second) of+          ([p0,p1,p2,p3], []) -> do+            (r, exp) <- getSomeReg v1+            let imm = makeMask [p0,p1,p2,p3]+                code dst = exp `appOL` pshufd imm r dst+            return $ Any fmt code++          ([], [q0,q1,q2,q3]) -> do+            (r, exp) <- getSomeReg v2+            let imm = makeMask [q0,q1,q2,q3]+                code dst = exp `appOL` pshufd imm r dst+            return $ Any fmt code++          ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 0b11_10_01_00 v1 v2+          ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1+          ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2++          _ -> pprPanic "vector shuffle: cannot occur" (ppr is)+      where fmt = VecFormat 4 FmtInt32++    vector_shuffle_int64x2 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int64x2 sse4_1 v1 v2 is+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = case is of+        -- PUNPCKLQDQ / PUNPCKHQDQ+        [i, i'] | i == i' -> do+          exp <- getAnyReg $ if i < 2 then v1 else v2+          let instr = if i == 0 || i == 2+                      then PUNPCKLQDQ+                      else PUNPCKHQDQ+              code dst = exp dst `snocOL`+                         (instr fmt (OpReg dst) dst)+          return $ Any fmt code+        [0, 2] -> vector_op_sse PUNPCKLQDQ fmt v1 v2+        [2, 0] -> vector_op_sse PUNPCKLQDQ fmt v2 v1+        [1, 3] -> vector_op_sse PUNPCKHQDQ fmt v1 v2+        [3, 1] -> vector_op_sse PUNPCKHQDQ fmt v2 v1++        -- PSHUFD+        [1, 0] -> do+          (r1, exp1) <- getSomeReg v1+          let code dst = exp1 `snocOL`+                         (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r1) dst)+          return $ Any fmt code+        [3, 2] -> do+          (r2, exp2) <- getSomeReg v2+          let code dst = exp2 `snocOL`+                         (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r2) dst)+          return $ Any fmt code++        -- Others:+        -- If SSE4.1 is available, use PBLENDW (see vector_shuffle_int128_common).+        -- Otherwise, we resort to SHUFPD.+        [0, 3] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v1 v2+        [2, 1] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v2 v1++        -- [0, 1], [2, 3], [1, 2], [3, 0] are covered by the common cases++        -- Indices are checked in vector_shuffle_int128_common, so the following line should be unreachable:+        _ -> pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)+      where fmt = VecFormat 2 FmtInt64+            doubleFormat = VecFormat 2 FmtDouble+++getRegister' platform _is32Bit (CmmMachOp mop [x, y, z]) = do -- ternary MachOps+  avx    <- avxEnabled+  sse4_1 <- sse4_1Enabled+  case mop of+      -- Floating point fused multiply-add operations @ ± x*y ± z@+      MO_FMA var l w+        | l * widthInBits w > 256+        -> sorry "Please use -fllvm for wide vector FMA support"+        | otherwise+        -> genFMA3Code l w var x y z++      -- Ternary vector operations+      MO_VF_Insert l W32  | l == 4 -> vector_floatx4_insert_sse sse4_1 x y z+                          | otherwise ->+         sorry $ "FloatX" ++ show l ++ "# insert operations require -fllvm"+           -- SIMD NCG TODO:+           --+           --   - add support for FloatX8, FloatX16.+      MO_VF_Insert l W64  -> vector_double_insert avx l x y z+      MO_V_Insert 16 W8 | sse4_1 -> vector_int_insert_pinsr 16 W8 x y z+                        | otherwise -> vector_int8x16_insert_sse2 x y z+      MO_V_Insert 8 W16 -> vector_int_insert_pinsr 8 W16 x y z -- PINSRW (SSE2)+      MO_V_Insert 4 W32 | sse4_1 -> vector_int_insert_pinsr 4 W32 x y z+                        | otherwise -> vector_int32x4_insert_sse2 x y z+      MO_V_Insert 2 W64 | sse4_1 -> vector_int_insert_pinsr 2 W64 x y z+                        | otherwise -> vector_int64x2_insert_sse2 x y z+      MO_V_Insert _ _ -> sorry "Unsupported integer vector insert operation; please use -fllvm"++      _other -> pprPanic "getRegister(x86) - ternary CmmMachOp (1)"+                  (pprMachOp mop)++  where+    -- SIMD NCG TODO:+    --+    --   - add support for FloatX8, FloatX16.+    vector_floatx4_insert_sse :: Bool+                              -> CmmExpr+                              -> CmmExpr+                              -> CmmExpr+                              -> NatM Register+    vector_floatx4_insert_sse sse4_1 vecExpr valExpr (CmmLit (CmmInt offset _))+      | sse4_1 = do+        (r, exp)    <- getNonClobberedReg valExpr+        fn          <- getAnyReg vecExpr+        let fmt      = VecFormat 4 FmtFloat+            imm      = litToImm (CmmInt (offset `shiftL` 4) W32)+            code dst = exp `appOL`+                      (fn dst) `snocOL`+                      (INSERTPS fmt imm (OpReg r) dst)+         in return $ Any fmt code+      | otherwise = do -- SSE <= 3+        (r, exp)    <- getNonClobberedReg valExpr+        fn          <- getAnyReg vecExpr+        let fmt      = VecFormat 4 FmtFloat+        tmp <- getNewRegNat fmt+        let code dst+              = case offset of+                  0 -> exp `appOL`+                      (fn dst) `snocOL`+                      -- The following MOV compiles to MOVSS instruction and merges two vectors+                      (MOV fmt (OpReg r) (OpReg dst))  -- dst <- (r[0],dst[1],dst[2],dst[3])+                  1 -> exp `appOL`+                      (fn dst) `snocOL`+                      (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst+                      (UNPCKL fmt (OpReg r) dst) `snocOL`          -- dst <- (dst[0],r[0],dst[1],r[1])+                      (SHUF fmt (ImmInt 0xe4) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[2],tmp[3])+                  2 -> exp `appOL`+                       (fn dst) `snocOL`+                       (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst+                       (MOV fmt (OpReg r) (OpReg tmp)) `snocOL`     -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS+                       (SHUF fmt (ImmInt 0xc4) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[0],tmp[3])+                  3 -> exp `appOL`+                       (fn dst) `snocOL`+                       (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst+                       (MOV fmt (OpReg r) (OpReg tmp)) `snocOL`     -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS+                       (SHUF fmt (ImmInt 0x24) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[2],tmp[0])+                  _ -> panic "MO_VF_Insert FloatX4: unsupported offset"+         in return $ Any fmt code+    vector_floatx4_insert_sse _ _ _ offset+      = pprPanic "Unsupported vector insert operation" $+          vcat+            [ text "FloatX4#"+            , text "offset:" <+> pdoc platform offset ]+++    -- SIMD NCG TODO:+    --+    --   - add support for DoubleX4#, DoubleX8#.+    vector_double_insert :: Bool+                         -> Length+                         -> CmmExpr+                         -> CmmExpr+                         -> CmmExpr+                         -> NatM Register+    -- DoubleX2+    vector_double_insert avx len@2 vecExpr valExpr (CmmLit offset)+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction+        let movu = if avx then VMOVU else MOVU+            fmt = VecFormat len FmtDouble+            code dst+              = case offset of+                  CmmInt 0 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL`+                                -- The following MOV compiles to MOVSD instruction and merges two vectors+                                (MOV (VecFormat 2 FmtDouble) (OpReg valReg) (OpReg dst))+                  CmmInt 1 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL`+                                (SHUF fmt (ImmInt 0b00) (OpReg valReg) dst)+                  _ -> pprPanic "MO_VF_Insert DoubleX2: unsupported offset" (ppr offset)+         in return $ Any fmt code+    vector_double_insert _ _ _ _ _ =+      sorry "Unsupported floating-point vector insert operation; please use -fllvm"+    -- For DoubleX4: use VSHUFPD.+    -- For DoubleX8: use something like vinsertf64x2 followed by vpblendd?++    -- SIMD NCG TODO:+    --+    --   - only supports 128-bit vector types (Int64X2, Int32X4, Int16X8, Int8X16),+    --     add support for 256-bit and 512-bit vector types.++    -- PINSRW is an SSE2 instruction, whereas PINSR{B,D,Q} require SSE4.1.+    vector_int_insert_pinsr :: HasCallStack => Length+                            -> Width+                            -> CmmExpr+                            -> CmmExpr+                            -> CmmExpr+                            -> NatM Register+    vector_int_insert_pinsr len w vecExpr valExpr (CmmLit (CmmInt offset _))+      | 0 <= offset, offset < toInteger len+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        vecCode <- getAnyReg vecExpr+        let (scalarFormat, vectorFormat) = case w of+              W8 -> (II32, VecFormat len FmtInt8)+              W16 -> (II32, VecFormat len FmtInt16)+              W32 -> (II32, VecFormat len FmtInt32)+              W64 -> (II64, VecFormat len FmtInt64)+              _ -> sorry "Unsupported vector format"+            code dst = valExp `appOL`+                       (vecCode dst) `snocOL`+                       (PINSR scalarFormat vectorFormat (ImmInteger offset) (OpReg valReg) dst)+        return $ Any vectorFormat code+    vector_int_insert_pinsr _ _ _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset)++    vector_int8x16_insert_sse2 :: CmmExpr+                               -> CmmExpr+                               -> CmmExpr+                               -> NatM Register+    vector_int8x16_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _))+      | 0 <= offset, offset < 16+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        vecCode <- getAnyReg vecExpr+        tmp <- getNewRegNat II32+        let vectorFormat = VecFormat 16 FmtInt8+            code dst+              = case offset `quotRem` 2 of+                  (j, 0) -> valExp `appOL`+                            (vecCode dst) `snocOL`+                            (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW+                            (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)) `snocOL`+                            (MOVZxL II8 (OpReg valReg) (OpReg valReg)) `snocOL`+                            (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL`+                            (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW+                  (j, _) -> valExp `appOL`+                            (vecCode dst) `snocOL`+                            (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW+                            (MOVZxL II8 (OpReg tmp) (OpReg tmp)) `snocOL`+                            (SHL II32 (OpImm (ImmInt 8)) (OpReg valReg)) `snocOL`+                            (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL`+                            (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW+        return $ Any vectorFormat code+    vector_int8x16_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset)++    vector_int32x4_insert_sse2 :: CmmExpr+                               -> CmmExpr+                               -> CmmExpr+                               -> NatM Register+    vector_int32x4_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _))+      | 0 <= offset, offset < 4+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        vecCode <- getAnyReg vecExpr+        -- Since SSE2 does not have an integer vector instruction to achieve this,+        -- we are forced to either use floating-point vector instructions+        -- or lots of integer vector instructions. (sigh)+        let floatVectorFormat = VecFormat 4 FmtFloat+        tmp1 <- getNewRegNat floatVectorFormat+        tmp2 <- getNewRegNat floatVectorFormat+        let vectorFormat = VecFormat 4 FmtInt32+            code dst+              = case offset of+                  0 -> valExp `appOL`+                       (vecCode dst) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL`+                       (MOV floatVectorFormat (OpReg tmp1) (OpReg dst)) -- MOVSS; dst <- (tmp1[0],dst[1],dst[2],dst[3])+                  1 -> valExp `appOL`+                       (vecCode tmp1) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg dst)) `snocOL` -- dst <- (val,0,0,0)+                       (PUNPCKLQDQ vectorFormat (OpReg tmp1) dst) `snocOL` -- dst <- (dst[0],dst[1],tmp1[0],tmp1[1])+                       (SHUF floatVectorFormat (ImmInt 0b11_10_00_10) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[2],dst[0],tmp1[2],tmp1[3])+                  2 -> valExp `appOL`+                       (vecCode dst) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0)+                       (MOVU floatVectorFormat (OpReg dst) (OpReg tmp2)) `snocOL` -- MOVUPS; tmp2 <- dst+                       (SHUF floatVectorFormat (ImmInt 0b01_00_01_11) (OpReg tmp1) tmp2) `snocOL` -- SHUFPS; tmp2 <- (tmp2[3],tmp2[1],tmp1[0],tmp1[1])+                       (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp2) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp2[2],tmp2[0])+                  _ -> valExp `appOL`+                       (vecCode dst) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0)+                       (SHUF floatVectorFormat (ImmInt 0b11_10_01_00) (OpReg dst) tmp1) `snocOL` -- SHUFPS; tmp1 <- (tmp1[0],tmp1[1],dst[2],dst[3])+                       (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp1[2],tmp1[0])+        return $ Any vectorFormat code+    vector_int32x4_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset)++    vector_int64x2_insert_sse2 :: CmmExpr+                               -> CmmExpr+                               -> CmmExpr+                               -> NatM Register+    vector_int64x2_insert_sse2 vecExpr valExpr (CmmLit offset)+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction+        let fmt = VecFormat 2 FmtInt64+        tmp <- getNewRegNat fmt+        let code dst+              = case offset of+                  CmmInt 0 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (MOVHLPS FF64 vecReg tmp) `snocOL`+                                (MOVD II64 fmt (OpReg valReg) (OpReg dst)) `snocOL`+                                (PUNPCKLQDQ fmt (OpReg tmp) dst)+                  CmmInt 1 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (MOVDQU fmt (OpReg vecReg) (OpReg dst)) `snocOL`+                                (MOVD II64 fmt (OpReg valReg) (OpReg tmp)) `snocOL`+                                (PUNPCKLQDQ fmt (OpReg tmp) dst)+                  _ -> pprPanic "MO_V_Insert Int64X2: unsupported offset" (ppr offset)+         in return $ Any fmt code+    vector_int64x2_insert_sse2 _ _ offset = pprPanic "MO_V_Insert Int64X2: unsupported offset" (pdoc platform offset)++getRegister' _ _ (CmmMachOp mop (_:_:_:_:_)) =+  pprPanic "getRegister(x86): MachOp with >= 4 arguments" (text $ show mop)++getRegister' platform is32Bit load@(CmmLoad mem ty _)+  | isVecType ty+  = do+    config <- getConfig+    Amode addr mem_code <- getAmode mem+    let code dst =+          mem_code `snocOL`+            movInstr config format (OpAddr addr) (OpReg dst)+    return (Any format code)+  | isFloatType ty+  = do+    Amode addr mem_code <- getAmode mem+    loadAmode (floatFormat width) addr mem_code++  | is32Bit && not (isWord64 ty)+  = do+    let+      instr = case width of+                W8     -> MOVZxL II8+                  -- We always zero-extend 8-bit loads, if we+                  -- can't think of anything better.  This is because+                  -- we can't guarantee access to an 8-bit variant of every register+                  -- (esi and edi don't have 8-bit variants), so to make things+                  -- simpler we do our 8-bit arithmetic with full 32-bit registers.+                _other -> MOV format+    code <- intLoadCode instr mem+    return (Any format code)++  | not is32Bit+  -- Simpler memory load code on x86_64+  = do+    code <- intLoadCode (MOV format) mem+    return (Any format code)++  | otherwise+  = pprPanic "getRegister(x86) CmmLoad" (pdoc platform load)+  where+    format = cmmTypeFormat ty+    width = typeWidth ty++-- Handle symbol references with LEA and %rip-relative addressing.+-- See Note [%rip-relative addressing on x86-64].+getRegister' platform is32Bit (CmmLit lit)+  | is_label lit+  , not is32Bit+  = do let format = cmmTypeFormat (cmmLitType platform lit)+           imm = litToImm lit+           op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm)+           code dst = unitOL (LEA format op (OpReg dst))+       return (Any format code)+  where+    is_label (CmmLabel {})        = True+    is_label (CmmLabelOff {})     = True+    is_label (CmmLabelDiffOff {}) = True+    is_label _                    = False++getRegister' platform is32Bit (CmmLit lit) = do+  avx <- avxEnabled++  -- NB: it is important that the code produced here (to load a literal into+  -- a register) doesn't clobber any registers other than the destination+  -- register; the code for generating C calls relies on this property.+  --+  -- In particular, we have:+  --+  -- > loadIntoRegMightClobberOtherReg (CmmLit _) = False+  --+  -- which means that we assume that loading a literal into a register+  -- will not clobber any other registers.++  -- TODO: this function mishandles floating-point negative zero,+  -- because -0.0 == 0.0 returns True and because we represent CmmFloat as+  -- Rational, which can't properly represent negative zero.++  if+    -- Zero: use XOR.+    | isZeroLit lit+    -> let code dst+             | isIntFormat fmt+             = let fmt'+                     | is32Bit+                     = fmt+                     | otherwise+                     -- x86_64: 32-bit xor is one byte shorter,+                     -- and zero-extends to 64 bits+                     = case fmt of+                         II64 -> II32+                         _ -> fmt+               in unitOL (XOR fmt' (OpReg dst) (OpReg dst))+             | avx+             = if float_or_floatvec+               then unitOL (VXOR fmt (OpReg dst) dst dst)+               else unitOL (VPXOR fmt dst dst dst)+             | otherwise+             = if float_or_floatvec+               then unitOL (XOR fmt (OpReg dst) (OpReg dst))+               else unitOL (PXOR fmt (OpReg dst) dst)+       in return $ Any fmt code++    -- Constant vector: use broadcast.+    | VecFormat l sFmt <- fmt+    , CmmVec (f:fs) <- lit+    , all (== f) fs+    -> do let w = scalarWidth sFmt+              broadcast = if isFloatScalarFormat sFmt+                          then MO_VF_Broadcast l w+                          else MO_V_Broadcast l w+          valCode <- getAnyReg (CmmMachOp broadcast [CmmLit f])+          return $ Any fmt valCode++    -- Optimisation for loading small literals on x86_64: take advantage+    -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit+    -- instruction forms are shorter.+    | not is32Bit, isWord64 cmmTy, not (isBigLit lit)+    -> let+          imm = litToImm lit+          code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))+      in+          return (Any II64 code)++    -- Scalar integer: use an immediate.+    | isIntFormat fmt+    -> let imm = litToImm lit+           code dst = unitOL (MOV fmt (OpImm imm) (OpReg dst))+       in return (Any fmt code)++    -- General case: load literal from data address.+    | otherwise+    -> do let w = formatToWidth fmt+          Amode addr addr_code <- memConstant (mkAlignment $ widthInBytes w) lit+          loadAmode fmt addr addr_code++    where+      cmmTy = cmmLitType platform lit+      fmt = cmmTypeFormat cmmTy+      float_or_floatvec = isFloatOrFloatVecFormat fmt+      isZeroLit (CmmInt i _) = i == 0+      isZeroLit (CmmFloat f _) = f == 0 -- TODO: mishandles negative zero+      isZeroLit (CmmVec fs) = all isZeroLit fs+      isZeroLit _ = False++      isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff+      isBigLit _ = False+        -- note1: not the same as (not.is32BitLit), because that checks for+        -- signed literals that fit in 32 bits, but we want unsigned+        -- literals here.+        -- note2: all labels are small, because we're assuming the+        -- small memory model. See Note [%rip-relative addressing on x86-64].++getRegister' platform _ slot@(CmmStackSlot {}) =+  pprPanic "getRegister(x86) CmmStackSlot" (pdoc platform slot)++intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr+   -> NatM (Reg -> InstrBlock)+intLoadCode instr mem = do+  Amode src mem_code <- getAmode mem+  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))++-- Compute an expression into *any* register, adding the appropriate+-- move instruction if necessary.+getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock)+getAnyReg expr = do+  r <- getRegister expr+  anyReg r++anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock)+anyReg (Any _ code)          = return code+anyReg (Fixed rep reg fcode) = do+  config <- getConfig+  return (\dst -> fcode `snocOL` mkRegRegMoveInstr config rep reg dst)++-- A bit like getSomeReg, but we want a reg that can be byte-addressed.+-- Fixed registers might not be byte-addressable, so we make sure we've+-- got a temporary, inserting an extra reg copy if necessary.+getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)+getByteReg expr = do+  config <- getConfig+  is32Bit <- is32BitPlatform+  if is32Bit+      then do r <- getRegister expr+              case r of+                Any rep code -> do+                    tmp <- getNewRegNat rep+                    return (tmp, code tmp)+                Fixed rep reg code+                    | isVirtualReg reg -> return (reg,code)+                    | otherwise -> do+                        tmp <- getNewRegNat rep+                        return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp)+                    -- ToDo: could optimise slightly by checking for+                    -- byte-addressable real registers, but that will+                    -- happen very rarely if at all.+      else getSomeReg expr -- all regs are byte-addressable on x86_64++-- Another variant: this time we want the result in a register that cannot+-- be modified by code to evaluate an arbitrary expression.+getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)+getNonClobberedReg expr = do+  r <- getRegister expr+  config <- getConfig+  let platform = ncgPlatform config+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed rep reg code+        -- only certain regs can be clobbered+        | reg `elem` instrClobberedRegs platform+        -> do+                tmp <- getNewRegNat rep+                return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp)+        | otherwise ->+                return (reg, code)++--------------------------------------------------------------------------------++-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.+--+-- An 'Amode' is a datatype representing a valid address form for the target+-- (e.g. "Base + Index + disp" or immediate) and the code to compute it.+getAmode :: CmmExpr -> NatM Amode+getAmode e = do+   platform <- getPlatform+   let is32Bit = target32Bit platform++   case e of+      CmmRegOff r n+         -> getAmode $ mangleIndexTree r n++      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), CmmLit displacement]+         | not is32Bit+         -> return $ Amode (ripRel (litToImm displacement)) nilOL++      -- This is all just ridiculous, since it carefully undoes+      -- what mangleIndexTree has just done.+      CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]+         | is32BitLit platform lit+         -- assert (rep == II32)???+         -> do+            (x_reg, x_code) <- getSomeReg x+            let off = ImmInt (-(fromInteger i))+            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++      CmmMachOp (MO_Add _rep) [x, CmmLit lit]+         | is32BitLit platform lit+         -- assert (rep == II32)???+         -> do+            (x_reg, x_code) <- getSomeReg x+            let off = litToImm lit+            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++      -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be+      -- recognised by the next rule.+      CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]+         -> getAmode (CmmMachOp (MO_Add rep) [b,a])++      -- Matches: (x + offset) + (y << shift)+      CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)++      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         -> x86_complex_amode x y shift 0++      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)+                                                    [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         && is32BitInteger offset+         -> x86_complex_amode x y shift offset++      CmmMachOp (MO_Add _) [x,y]+         | not (isLit y) -- we already handle valid literals above.+         -> x86_complex_amode x y 0 0++      CmmLit lit@(CmmFloat {})+        -> pprPanic "X86 CodeGen: attempt to use floating-point value as a memory address"+             (ppr lit)++      -- Handle labels with %rip-relative addressing since in general the image+      -- may be loaded anywhere in the 64-bit address space (e.g. on Windows+      -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64].+      CmmLit lit+         | not is32Bit+         , is_label lit+         -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL)++      CmmLit lit+         | is32BitLit platform lit+         -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)++      -- Literal with offsets too big (> 32 bits) fails during the linking phase+      -- (#15570). We already handled valid literals above so we don't have to+      -- test anything here.+      CmmLit (CmmLabelOff l off)+         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)+                                             , CmmLit (CmmInt (fromIntegral off) W64)+                                             ])+      CmmLit (CmmLabelDiffOff l1 l2 off w)+         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)+                                             , CmmLit (CmmInt (fromIntegral off) W64)+                                             ])++      -- in case we can't do something better, we just compute the expression+      -- and put the result in a register+      _ -> do+        (reg,code) <- getSomeReg e+        return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)+  where+    is_label (CmmLabel{}) = True+    is_label (CmmLabelOff{}) = True+    is_label (CmmLabelDiffOff{}) = True+    is_label _ = False+++-- | Like 'getAmode', but on 32-bit use simple register addressing+-- (i.e. no index register). This stops us from running out of+-- registers on x86 when using instructions such as cmpxchg, which can+-- use up to three virtual registers and one fixed register.+getSimpleAmode :: CmmExpr -> NatM Amode+getSimpleAmode addr = is32BitPlatform >>= \case+  False -> getAmode addr+  True  -> do+    addr_code <- getAnyReg addr+    config <- getConfig+    addr_r <- getNewRegNat (intFormat (ncgWordWidth config))+    let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)+    return $! Amode amode (addr_code addr_r)++x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode+x86_complex_amode base index shift offset+  = do (x_reg, x_code) <- getNonClobberedReg base+        -- x must be in a temp, because it has to stay live over y_code+        -- we could compare x_reg and y_reg and do something better here...+       (y_reg, y_code) <- getSomeReg index+       let+           code = x_code `appOL` y_code+           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;+                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"+       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))+               code)+++++-- -----------------------------------------------------------------------------+-- getOperand: sometimes any operand will do.++-- getNonClobberedOperand: the value of the operand will remain valid across+-- the computation of an arbitrary expression, unless the expression+-- is computed directly into a register which the operand refers to+-- (see trivialCode where this function is used for an example).++getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand (CmmLit lit)+  | Just w <- isSuitableFloatingPointLit_maybe lit = do+    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+    return (OpAddr addr, code)+  | otherwise = do+    platform <- getPlatform+    if is32BitLit platform lit && isIntFormat (cmmTypeFormat (cmmLitType platform lit))+    then return (OpImm (litToImm lit), nilOL)+    else getNonClobberedOperand_generic (CmmLit lit)++getNonClobberedOperand (CmmLoad mem ty _) = do+  is32Bit <- is32BitPlatform+  -- this logic could be simplified+  -- TODO FIXME+  if   (if is32Bit then not (isWord64 ty) else True)+      -- if 32bit and ty is at float/double/simd value+      -- or if 64bit+      --  this could use some eyeballs or i'll need to stare at it more later+    then do+      platform <- ncgPlatform <$> getConfig+      Amode src mem_code <- getAmode mem+      (src',save_code) <-+        if (amodeCouldBeClobbered platform src)+                then do+                   tmp <- getNewRegNat (archWordFormat is32Bit)+                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),+                           unitOL (LEA (archWordFormat is32Bit)+                                       (OpAddr src)+                                       (OpReg tmp)))+                else+                   return (src, nilOL)+      return (OpAddr src', mem_code `appOL` save_code)+    else+      -- if its a word or gcptr on 32bit?+      getNonClobberedOperand_generic (CmmLoad mem ty NaturallyAligned)++getNonClobberedOperand e = getNonClobberedOperand_generic e++getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand_generic e = do+  (reg, code) <- getNonClobberedReg e+  return (OpReg reg, code)++amodeCouldBeClobbered :: Platform -> AddrMode -> Bool+amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)++regClobbered :: Platform -> Reg -> Bool+regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr+regClobbered _ _ = False++-- getOperand: the operand is not required to remain valid across the+-- computation of an arbitrary expression.+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)++getOperand (CmmLit lit) = case isSuitableFloatingPointLit_maybe lit of+    Just w -> do+        Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+        return (OpAddr addr, code)+    Nothing -> do+        platform <- getPlatform+        if is32BitLit platform lit && (isIntFormat $ cmmTypeFormat (cmmLitType platform lit))+            then return (OpImm (litToImm lit), nilOL)+            else getOperand_generic (CmmLit lit)++getOperand (CmmLoad mem ty _) = do+  is32Bit <- is32BitPlatform+  if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else+       getOperand_generic (CmmLoad mem ty NaturallyAligned)++getOperand e = getOperand_generic e++getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getOperand_generic e = do+    (reg, code) <- getSomeReg e+    return (OpReg reg, code)++isOperand :: Platform -> CmmExpr -> Bool+isOperand _ (CmmLoad _ _ _) = True+isOperand platform (CmmLit lit)+                          = is32BitLit platform lit+                          || isSuitableFloatingPointLit lit+isOperand _ _            = False++-- | Given a 'Register', produce a new 'Register' with an instruction block+-- which will check the value for alignment. Used for @-falignment-sanitisation@.+addAlignmentCheck :: Int -> Register -> Register+addAlignmentCheck align reg =+    case reg of+      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)+      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)+  where+    check :: Format -> Reg -> InstrBlock+    check fmt reg =+        assert (isIntFormat fmt) $+        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)+             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel+             ]++memConstant :: Alignment -> CmmLit -> NatM Amode+memConstant align lit = do+  lbl <- getNewLabelNat+  let rosection = Section ReadOnlyData lbl+  config <- getConfig+  platform <- getPlatform+  (addr, addr_code) <- if target32Bit platform+                       then do dynRef <- cmmMakeDynamicReference+                                             config+                                             DataReference+                                             lbl+                               Amode addr addr_code <- getAmode dynRef+                               return (addr, addr_code)+                       else return (ripRel (ImmCLbl lbl), nilOL)+  let code =+        LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])+        `consOL` addr_code+  return (Amode addr code)++-- | Load the value at the given address into any register.+loadAmode :: Format -> AddrMode -> InstrBlock -> NatM Register+loadAmode fmt addr addr_code = do+  config <- getConfig+  let load dst = movInstr config fmt (OpAddr addr) (OpReg dst)+  return $ Any fmt (\ dst -> addr_code `snocOL` load dst)++-- if we want a floating-point literal as an operand, we can+-- use it directly from memory.  However, if the literal is+-- zero, we're better off generating it into a register using+-- xor.+isSuitableFloatingPointLit :: CmmLit -> Bool+isSuitableFloatingPointLit = isJust . isSuitableFloatingPointLit_maybe++isSuitableFloatingPointLit_maybe :: CmmLit -> Maybe Width+isSuitableFloatingPointLit_maybe (CmmFloat f w) = w <$ guard (f /= 0.0)+isSuitableFloatingPointLit_maybe _ = Nothing++getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)+getRegOrMem e@(CmmLoad mem ty _) = do+  is32Bit <- is32BitPlatform+  if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else do+       (reg, code) <- getNonClobberedReg e+       return (OpReg reg, code)+getRegOrMem e = do+    (reg, code) <- getNonClobberedReg e+    return (OpReg reg, code)++is32BitLit :: Platform -> CmmLit -> Bool+is32BitLit platform _lit+   | target32Bit platform = True+is32BitLit platform lit =+   case lit of+      CmmInt i W64              -> is32BitInteger i+      -- Except on Windows, assume that labels are in the range 0-2^31-1: this+      -- assumes the small memory model. Note [%rip-relative addressing on+      -- x86-64].+      CmmLabel _                -> low_image+      -- however we can't assume that label offsets are in this range+      -- (see #15570)+      CmmLabelOff _ off         -> low_image && is32BitInteger (fromIntegral off)+      CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off)+      _                         -> True+  where+    -- Is the executable image certain to be located below 4GB? As noted in+    -- Note [%rip-relative addressing on x86-64], this is not true on Windows.+    low_image =+      case platformOS platform of+        OSMinGW32 -> False   -- See Note [%rip-relative addressing on x86-64]+        _         -> True+++-- Set up a condition code for a conditional branch.++getCondCode :: CmmExpr -> NatM CondCode++-- yes, they really do seem to want exactly the same!++getCondCode (CmmMachOp mop [x, y])+  =+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt W32 -> condFltCode GTT  y x+      MO_F_Le W32 -> condFltCode GE   y x++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode GTT y x+      MO_F_Le W64 -> condFltCode GE  y x++      _ -> condIntCode (machOpToCond mop) x y++getCondCode other = do+   platform <- getPlatform+   pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)++machOpToCond :: MachOp -> Cond+machOpToCond mo = case mo of+  MO_Eq _   -> EQQ+  MO_Ne _   -> NE+  MO_S_Gt _ -> GTT+  MO_S_Ge _ -> GE+  MO_S_Lt _ -> LTT+  MO_S_Le _ -> LE+  MO_U_Gt _ -> GU+  MO_U_Ge _ -> GEU+  MO_U_Lt _ -> LU+  MO_U_Le _ -> LEU+  _other -> pprPanic "machOpToCond" (pprMachOp mo)++{-  Note [64-bit integer comparisons on 32-bit]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    When doing these comparisons there are 2 kinds of+    comparisons.++    * Comparison for equality (or lack thereof)++    We use xor to check if high/low bits are+    equal. Then combine the results using or.++    * Other comparisons:++    We first compare the low registers+    and use a subtraction with borrow to compare the high registers.++    For signed numbers the condition is determined by+    the sign and overflow flags agreeing or not+    and for unsigned numbers the condition is the carry flag.++-}++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond x y = do platform <- getPlatform+                          condIntCode' platform cond x y++condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode++-- 64-bit integer comparisons on 32-bit+-- See Note [64-bit integer comparisons on 32-bit]+condIntCode' platform cond x y+  | target32Bit platform && isWord64 (cmmExprType platform x) = do++  RegCode64 code1 r1hi r1lo <- iselExpr64 x+  RegCode64 code2 r2hi r2lo <- iselExpr64 y++  -- we mustn't clobber r1/r2 so we use temporaries+  tmp1 <- getNewRegNat II32+  tmp2 <- getNewRegNat II32++  let (cond', cmpCode) = intComparison cond r1hi r1lo r2hi r2lo tmp1 tmp2+  return $ CondCode False cond' (code1 `appOL` code2 `appOL` cmpCode)++  where+    intComparison cond r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =+      case cond of+        -- These don't occur as argument of condIntCode'+        ALWAYS  -> panic "impossible"+        NEG     -> panic "impossible"+        POS     -> panic "impossible"+        CARRY   -> panic "impossible"+        OFLO    -> panic "impossible"+        PARITY  -> panic "impossible"+        NOTPARITY -> panic "impossible"+        -- Special case #1 x == y and x != y+        EQQ -> (EQQ, cmpExact)+        NE  -> (NE, cmpExact)+        -- [x >= y]+        GE  -> (GE, cmpGE)+        GEU -> (GEU, cmpGE)+        -- [x >  y]+        GTT -> (LTT, cmpLE)+        GU  -> (LU, cmpLE)+        -- [x <= y]+        LE  -> (GE, cmpLE)+        LEU -> (GEU, cmpLE)+        -- [x <  y]+        LTT -> (LTT, cmpGE)+        LU  -> (LU, cmpGE)+      where+        cmpExact :: OrdList Instr+        cmpExact =+          toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , MOV II32 (OpReg r1_lo) (OpReg tmp2)+            , XOR II32 (OpReg r2_hi) (OpReg tmp1)+            , XOR II32 (OpReg r2_lo) (OpReg tmp2)+            , OR  II32 (OpReg tmp1)  (OpReg tmp2)+            ]+        cmpGE = toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)+            , SBB II32 (OpReg r2_hi) (OpReg tmp1)+            ]+        cmpLE = toOL+            [ MOV II32 (OpReg r2_hi) (OpReg tmp1)+            , CMP II32 (OpReg r1_lo) (OpReg r2_lo)+            , SBB II32 (OpReg r1_hi) (OpReg tmp1)+            ]++-- memory vs immediate+condIntCode' platform cond (CmmLoad x ty _) (CmmLit lit)+ | is32BitLit platform lit = do+    Amode x_addr x_code <- getAmode x+    let+        imm  = litToImm lit+        code = x_code `snocOL`+                  CMP (cmmTypeFormat ty) (OpImm imm) (OpAddr x_addr)+    --+    return (CondCode False cond code)++-- anything vs zero, using a mask+-- TODO: Add some sanity checking!!!!+condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 ty))+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit+    = do+      (x_reg, x_code) <- getSomeReg x+      let+         code = x_code `snocOL`+                TEST (intFormat ty) (OpImm (ImmInteger mask)) (OpReg x_reg)+      --+      return (CondCode False cond code)++-- anything vs zero+condIntCode' _ cond x (CmmLit (CmmInt 0 ty)) = do+    (x_reg, x_code) <- getSomeReg x+    let+        code = x_code `snocOL`+                  TEST (intFormat ty) (OpReg x_reg) (OpReg x_reg)+    --+    return (CondCode False cond code)++-- anything vs operand+condIntCode' platform cond x y+ | isOperand platform y = do+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op,  y_code) <- getOperand y+    let+        code = x_code `appOL` y_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)+    return (CondCode False cond code)+-- operand vs. anything: invert the comparison so that we can use a+-- single comparison instruction.+ | isOperand platform x+ , Just revcond <- maybeFlipCond cond = do+    (y_reg, y_code) <- getNonClobberedReg y+    (x_op,  x_code) <- getOperand x+    let+        code = y_code `appOL` x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)+    return (CondCode False revcond code)++-- anything vs anything+condIntCode' platform cond x y = do+  (y_reg, y_code) <- getNonClobberedReg y+  (x_op, x_code) <- getRegOrMem x+  let+        code = y_code `appOL`+               x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op+  return (CondCode False cond code)++++--------------------------------------------------------------------------------+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode++condFltCode cond x y+  =  condFltCode_sse2+  where+++  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be+  -- an operand, but the right must be a reg.  We can probably do better+  -- than this general case...+  condFltCode_sse2 = do+    platform <- getPlatform+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op, y_code) <- getOperand y+    let+        code = x_code `appOL`+               y_code `snocOL`+                  CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)+        -- NB(1): we need to use the unsigned comparison operators on the+        -- result of this comparison.+    return (CondCode True (condToUnsigned cond) code)++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_VecCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_VecCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock++-- integer assignment to memory++-- specific case of adding/subtracting an integer to a particular address.+-- ToDo: catch other cases where we can use an operation directly on a memory+-- address.+assignMem_IntCode ty addr (CmmMachOp op [CmmLoad addr2 _ _,+                                                 CmmLit (CmmInt i _)])+   | addr == addr2, ty /= II64 || is32BitInteger i,+     Just instr <- check op+   = do Amode amode code_addr <- getAmode addr+        let code = code_addr `snocOL`+                   instr ty (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)+        return code+   where+        check (MO_Add _) = Just ADD+        check (MO_Sub _) = Just SUB+        check _ = Nothing+        -- ToDo: more?++-- general case+assignMem_IntCode ty addr src = do+    platform <- getPlatform+    Amode addr code_addr <- getAmode addr+    (code_src, op_src)   <- get_op_RI platform src+    let+        code = code_src `appOL`+               code_addr `snocOL`+                  MOV ty op_src (OpAddr addr)+        -- NOTE: op_src is stable, so it will still be valid+        -- after code_addr.  This may involve the introduction+        -- of an extra MOV to a temporary register, but we hope+        -- the register allocator will get rid of it.+    --+    return code+  where+    get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator+    get_op_RI platform (CmmLit lit) | is32BitLit platform lit+      = return (nilOL, OpImm (litToImm lit))+    get_op_RI _ op+      = do (reg,code) <- getNonClobberedReg op+           return (code, OpReg reg)+++-- Assign; dst is a reg, rhs is mem+assignReg_IntCode reg (CmmLoad src _ _) = do+  let ty = cmmTypeFormat $ cmmRegType reg+  load_code <- intLoadCode (MOV ty) src+  platform <- ncgPlatform <$> getConfig+  return (load_code (getRegisterReg platform reg))++-- dst is a reg, but src could be anything+assignReg_IntCode reg src = do+  platform <- ncgPlatform <$> getConfig+  code <- getAnyReg src+  return (code (getRegisterReg platform reg))+++-- Floating point assignment to memory+assignMem_FltCode ty addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  let+        code = src_code `appOL`+               addr_code `snocOL`+               MOV ty (OpReg src_reg) (OpAddr addr)++  return code++-- Floating point assignment to a register/temporary+assignReg_FltCode reg src = do+  src_code <- getAnyReg src+  platform <- ncgPlatform <$> getConfig+  return (src_code (getRegisterReg platform reg))++-- Vector assignment to a register/temporary+assignMem_VecCode ty addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  config <- getConfig+  let+    code = src_code `appOL`+           addr_code `snocOL`+           movInstr config ty (OpReg src_reg) (OpAddr addr)+  return code++assignReg_VecCode reg src = do+  platform <- ncgPlatform <$> getConfig+  src_code <- getAnyReg src+  return (src_code (getRegisterReg platform reg))++genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> NatM InstrBlock++genJump (CmmLoad mem _ _) regs = do+  Amode target code <- getAmode mem+  return (code `snocOL` JMP (OpAddr target) regs)++genJump (CmmLit lit) regs =+  return (unitOL (JMP (OpImm (litToImm lit)) regs))++genJump expr regs = do+  (reg,code) <- getSomeReg expr+  return (code `snocOL` JMP (OpReg reg) regs)+++-- -----------------------------------------------------------------------------+--  Unconditional branches++genBranch :: BlockId -> InstrBlock+genBranch = toOL . mkJumpInstr++++-- -----------------------------------------------------------------------------+--  Conditional jumps/branches++{-+Conditional jumps are always to local labels, so we can use branch+instructions.  We peek at the arguments to decide what kind of+comparison to do.++I386: First, we have to ensure that the condition+codes are set according to the supplied comparison operation.+-}++genCondBranch+    :: BlockId      -- the source of the jump+    -> BlockId      -- the true branch target+    -> BlockId      -- the false branch target+    -> CmmExpr      -- the condition on which to branch+    -> NatM InstrBlock -- Instructions++genCondBranch bid id false expr = do+  is32Bit <- is32BitPlatform+  genCondBranch' is32Bit bid id false expr++-- | We return the instructions generated.+genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr+               -> NatM InstrBlock++genCondBranch' _ bid id false bool = do+  CondCode is_float cond cond_code <- getCondCode bool+  if not is_float+    then+        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)+    else do+        -- See Note [SSE Parity Checks]+        let jmpFalse = genBranch false+            code+                = case cond of+                  NE  -> or_unordered+                  GU  -> plain_test+                  GEU -> plain_test+                  -- Use ASSERT so we don't break releases if+                  -- LTT/LE creep in somehow.+                  LTT ->+                    assertPpr False (text "Should have been turned into >")+                    and_ordered+                  LE  ->+                    assertPpr False (text "Should have been turned into >=")+                    and_ordered+                  _   -> and_ordered++            plain_test = unitOL (+                  JXX cond id+                ) `appOL` jmpFalse+            or_unordered = toOL [+                  JXX cond id,+                  JXX PARITY id+                ] `appOL` jmpFalse+            and_ordered = toOL [+                  JXX PARITY false,+                  JXX cond id,+                  JXX ALWAYS false+                ]+        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)+        return (cond_code `appOL` code)++{-  Note [Introducing cfg edges inside basic blocks]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    During instruction selection a statement `s`+    in a block B with control of the sort: B -> C+    will sometimes result in control+    flow of the sort:++            ┌ < ┐+            v   ^+      B ->  B1  ┴ -> C++    as is the case for some atomic operations.++    Now to keep the CFG in sync when introducing B1 we clearly+    want to insert it between B and C. However there is+    a catch when we have to deal with self loops.++    We might start with code and a CFG of these forms:++    loop:+        stmt1               ┌ < ┐+        ....                v   ^+        stmtX              loop ┘+        stmtY+        ....+        goto loop:++    Now we introduce B1:+                            ┌ ─ ─ ─ ─ ─┐+        loop:               │   ┌ <  ┐ │+        instrs              v   │    │ ^+        ....               loop ┴ B1 ┴ ┘+        instrsFromX+        stmtY+        goto loop:++    This is simple, all outgoing edges from loop now simply+    start from B1 instead and the code generator knows which+    new edges it introduced for the self loop of B1.++    Disaster strikes if the statement Y follows the same pattern.+    If we apply the same rule that all outgoing edges change then+    we end up with:++        loop ─> B1 ─> B2 ┬─┐+          │      │    └─<┤ │+          │      └───<───┘ │+          └───────<────────┘++    This is problematic. The edge B1->B1 is modified as expected.+    However the modification is wrong!++    The assembly in this case looked like this:++    _loop:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        <instrs>+        <end _B1>+    _B2:+        ...+        cmpxchgq ...+        jne _B2+        <instrs>+        jmp loop++    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.++    The problem here is that really B1 should be two basic blocks.+    Otherwise we have control flow in the *middle* of a basic block.+    A contradiction!++    So to account for this we add yet another basic block marker:++    _B:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        jmp _B1'+    _B1':+        <instrs>+        <end _B1>+    _B2:+        ...++    Now when inserting B2 we will only look at the outgoing edges of B1' and+    everything will work out nicely.++    You might also wonder why we don't insert jumps at the end of _B1'. There is+    no way another block ends up jumping to the labels _B1 or _B2 since they are+    essentially invisible to other blocks. View them as control flow labels local+    to the basic block if you'd like.++    Not doing this ultimately caused (part 2 of) #17334.+-}+++-- -----------------------------------------------------------------------------+--  Generating C calls++-- Now the biggest nightmare---calls.  Most of the nastiness is buried in+-- @get_arg@, which moves the arguments to the correct registers/stack+-- locations.  Apart from that, the code is easy.+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.+--+-- See Note [Keeping track of the current block] for information why we need+-- to take/return a block id.++genForeignCall+    :: ForeignTarget -- ^ function to call+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> BlockId       -- ^ The block we are in+    -> NatM (InstrBlock, Maybe BlockId)++genForeignCall target dst args bid = do+  case target of+    PrimTarget prim         -> genPrim bid prim dst args+    ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args++genPrim+    :: BlockId       -- ^ The block we are in+    -> CallishMachOp -- ^ MachOp+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> NatM (InstrBlock, Maybe BlockId)++-- First we deal with cases which might introduce new blocks in the stream.+genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n]+  = genAtomicRMW bid width amop dst addr n+genPrim bid (MO_Ctz width) [dst] [src]+  = genCtz bid width dst src++-- Then we deal with cases which not introducing new blocks in the stream.+genPrim bid prim dst args+  = (,Nothing) <$> genSimplePrim bid prim dst args++genSimplePrim+    :: BlockId       -- ^ the block we are in+    -> CallishMachOp -- ^ MachOp+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> NatM InstrBlock+genSimplePrim bid (MO_Memcpy align)    []      [dst,src,n]    = genMemCpy  bid align dst src n+genSimplePrim bid (MO_Memmove align)   []      [dst,src,n]    = genMemMove bid align dst src n+genSimplePrim bid (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  bid align res dst src n+genSimplePrim bid (MO_Memset align)    []      [dst,c,n]      = genMemSet  bid align dst c n+genSimplePrim _   MO_AcquireFence      []      []             = return nilOL -- barriers compile to no code on x86/x86-64;+genSimplePrim _   MO_ReleaseFence      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.+genSimplePrim _   MO_SeqCstFence       []      []             = return $ unitOL MFENCE+genSimplePrim _   MO_Touch             []      [_]            = return nilOL+genSimplePrim _   (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src+genSimplePrim _   (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src+genSimplePrim bid (MO_BRev width)      [dst]   [src]          = genBitRev bid width dst src+genSimplePrim bid (MO_PopCnt width)    [dst]   [src]          = genPopCnt bid width dst src+genSimplePrim bid (MO_Pdep width)      [dst]   [src,mask]     = genPdep bid width dst src mask+genSimplePrim bid (MO_Pext width)      [dst]   [src,mask]     = genPext bid width dst src mask+genSimplePrim bid (MO_Clz width)       [dst]   [src]          = genClz bid width dst src+genSimplePrim bid (MO_UF_Conv width)   [dst]   [src]          = genWordToFloat bid width dst src+genSimplePrim _   (MO_AtomicRead w mo)  [dst]  [addr]         = genAtomicRead w mo dst addr+genSimplePrim _   (MO_AtomicWrite w mo) []     [addr,val]     = genAtomicWrite w mo addr val+genSimplePrim bid (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg bid width dst addr old new+genSimplePrim _   (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value+genSimplePrim _   (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y+genSimplePrim _   (MO_SubWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y+genSimplePrim _   (MO_AddIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO  r c x y+genSimplePrim _   (MO_SubIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) OFLO  r c x y+genSimplePrim _   (MO_Add2 w)          [h,l]   [x,y]          = genAddWithCarry w h l x y+genSimplePrim _   (MO_U_Mul2 w)        [h,l]   [x,y]          = genUnsignedLargeMul w h l x y+genSimplePrim _   (MO_S_Mul2 w)        [c,h,l] [x,y]          = genSignedLargeMul w c h l x y+genSimplePrim _   (MO_S_QuotRem w)     [q,r]   [x,y]          = genQuotRem w True  q r Nothing   x  y+genSimplePrim _   (MO_U_QuotRem w)     [q,r]   [x,y]          = genQuotRem w False q r Nothing   x  y+genSimplePrim _   (MO_U_QuotRem2 w)    [q,r]   [hx,lx,y]      = genQuotRem w False q r (Just hx) lx y+genSimplePrim _   MO_F32_Fabs          [dst]   [src]          = genFloatAbs W32 dst src+genSimplePrim _   MO_F64_Fabs          [dst]   [src]          = genFloatAbs W64 dst src+genSimplePrim _   MO_F32_Sqrt          [dst]   [src]          = genFloatSqrt FF32 dst src+genSimplePrim _   MO_F64_Sqrt          [dst]   [src]          = genFloatSqrt FF64 dst src+genSimplePrim bid MO_F32_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sinf") [dst] [src]+genSimplePrim bid MO_F32_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cosf") [dst] [src]+genSimplePrim bid MO_F32_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tanf") [dst] [src]+genSimplePrim bid MO_F32_Exp           [dst]   [src]          = genLibCCall bid (fsLit "expf") [dst] [src]+genSimplePrim bid MO_F32_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1f") [dst] [src]+genSimplePrim bid MO_F32_Log           [dst]   [src]          = genLibCCall bid (fsLit "logf") [dst] [src]+genSimplePrim bid MO_F32_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1pf") [dst] [src]+genSimplePrim bid MO_F32_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asinf") [dst] [src]+genSimplePrim bid MO_F32_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acosf") [dst] [src]+genSimplePrim bid MO_F32_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atanf") [dst] [src]+genSimplePrim bid MO_F32_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinhf") [dst] [src]+genSimplePrim bid MO_F32_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "coshf") [dst] [src]+genSimplePrim bid MO_F32_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanhf") [dst] [src]+genSimplePrim bid MO_F32_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "powf")  [dst] [x,y]+genSimplePrim bid MO_F32_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinhf") [dst] [src]+genSimplePrim bid MO_F32_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acoshf") [dst] [src]+genSimplePrim bid MO_F32_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanhf") [dst] [src]+genSimplePrim bid MO_F64_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sin") [dst] [src]+genSimplePrim bid MO_F64_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cos") [dst] [src]+genSimplePrim bid MO_F64_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tan") [dst] [src]+genSimplePrim bid MO_F64_Exp           [dst]   [src]          = genLibCCall bid (fsLit "exp") [dst] [src]+genSimplePrim bid MO_F64_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1") [dst] [src]+genSimplePrim bid MO_F64_Log           [dst]   [src]          = genLibCCall bid (fsLit "log") [dst] [src]+genSimplePrim bid MO_F64_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1p") [dst] [src]+genSimplePrim bid MO_F64_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asin") [dst] [src]+genSimplePrim bid MO_F64_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acos") [dst] [src]+genSimplePrim bid MO_F64_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atan") [dst] [src]+genSimplePrim bid MO_F64_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinh") [dst] [src]+genSimplePrim bid MO_F64_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "cosh") [dst] [src]+genSimplePrim bid MO_F64_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanh") [dst] [src]+genSimplePrim bid MO_F64_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "pow")  [dst] [x,y]+genSimplePrim bid MO_F64_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinh") [dst] [src]+genSimplePrim bid MO_F64_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acosh") [dst] [src]+genSimplePrim bid MO_F64_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanh") [dst] [src]+genSimplePrim bid MO_SuspendThread     [tok]   [rs,i]         = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i]+genSimplePrim bid MO_ResumeThread      [rs]    [tok]          = genRTSCCall bid (fsLit "resumeThread") [rs] [tok]+genSimplePrim bid MO_I64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y]+genSimplePrim bid MO_I64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y]+genSimplePrim bid MO_W64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y]+genSimplePrim bid MO_W64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt8X16") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt16X8") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt32X4") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VS_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid (MO_VS_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt8X16") [dst] [x,y]+genSimplePrim bid (MO_VS_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt16X8") [dst] [x,y]+genSimplePrim bid (MO_VS_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt32X4") [dst] [x,y]+genSimplePrim bid (MO_VS_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VS_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid (MO_VU_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord8X16") [dst] [x,y]+genSimplePrim bid (MO_VU_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord16X8") [dst] [x,y]+genSimplePrim bid (MO_VU_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord32X4") [dst] [x,y]+genSimplePrim bid (MO_VU_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VU_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid (MO_VU_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord8X16") [dst] [x,y]+genSimplePrim bid (MO_VU_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord16X8") [dst] [x,y]+genSimplePrim bid (MO_VU_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord32X4") [dst] [x,y]+genSimplePrim bid (MO_VU_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VU_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid MO_I64X2_Min         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_minInt64X2") [dst] [x,y]+genSimplePrim bid MO_I64X2_Max         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_maxInt64X2") [dst] [x,y]+genSimplePrim bid MO_W64X2_Min         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_minWord64X2") [dst] [x,y]+genSimplePrim bid MO_W64X2_Max         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_maxWord64X2") [dst] [x,y]+genSimplePrim _   op                   dst     args           = do+  platform <- ncgPlatform <$> getConfig+  pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))++{- Note [Evaluate C-call arguments before placing in destination registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When producing code for C calls we must take care when placing arguments+in their final registers. Specifically, we must ensure that temporary register+usage due to evaluation of one argument does not clobber a register in which we+already placed a previous argument (e.g. as the code generation logic for+MO_Shl can clobber %rcx due to x86 instruction limitations).++This is precisely what happened in #18527. Consider this C--:++    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));++Here we are calling the C function `doSomething` with three arguments, the last+involving a non-trivial expression involving MO_Shl. In this case the NCG could+naively generate the following assembly (where $tmp denotes some temporary+register and $argN denotes the register for argument N, as dictated by the+platform's calling convention):++    mov _s2hp, $arg1   # place first argument+    mov _s2hq, $arg2   # place second argument++    # Compute 1 << _s2hz+    mov _s2hz, %rcx+    shl %cl, $tmp++    # Compute (_s2hw | (1 << _s2hz))+    mov _s2hw, $arg3+    or $tmp, $arg3++    # Perform the call+    call func++This code is outright broken on Windows which assigns $arg1 to %rcx. This means+that the evaluation of the last argument clobbers the first argument.++To avoid this we use a rather awful hack: when producing code for a C call with+at least one non-trivial argument, we first evaluate all of the arguments into+local registers before moving them into their final calling-convention-defined+homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an+expression which might contain a MachOp since these are the only cases which+might clobber registers. Furthermore, we use a conservative approximation of+this condition (only looking at the top-level of CmmExprs) to avoid spending+too much effort trying to decide whether we want to take the fast path.++Note that this hack *also* applies to calls to out-of-line PrimTargets (which+are lowered via a C call), which will ultimately end up in+genForeignCall{32,64}.+-}++-- | See Note [Evaluate C-call arguments before placing in destination registers]+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])+evalArgs bid actuals+  | any loadIntoRegMightClobberOtherReg actuals = do+      regs_blks <- mapM evalArg actuals+      return (concatOL $ map fst regs_blks, map snd regs_blks)+  | otherwise = return (nilOL, actuals)+  where++    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)+    evalArg actual = do+        platform <- getPlatform+        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)+        return (instrs, CmmReg $ CmmLocal lreg)++    newLocalReg :: CmmType -> NatM LocalReg+    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty++-- | Might the code to put this expression into a register+-- clobber any other registers?+loadIntoRegMightClobberOtherReg :: CmmExpr -> Bool+loadIntoRegMightClobberOtherReg (CmmReg _)      = False+loadIntoRegMightClobberOtherReg (CmmRegOff _ _) = False+loadIntoRegMightClobberOtherReg (CmmLit _)      = False+  -- NB: this last 'False' is slightly risky, because the code for loading+  -- a literal into a register is not entirely trivial.+loadIntoRegMightClobberOtherReg _               = True++-- Note [DIV/IDIV for bytes]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- IDIV reminder:+--   Size    Dividend   Divisor   Quotient    Remainder+--   byte    %ax         r/m8      %al          %ah+--   word    %dx:%ax     r/m16     %ax          %dx+--   dword   %edx:%eax   r/m32     %eax         %edx+--   qword   %rdx:%rax   r/m64     %rax         %rdx+--+-- We do a special case for the byte division because the current+-- codegen doesn't deal well with accessing %ah register (also,+-- accessing %ah in 64-bit mode is complicated because it cannot be an+-- operand of many instructions). So we just widen operands to 16 bits+-- and get the results from %al, %dl. This is not optimal, but a few+-- register moves are probably not a huge deal when doing division.+++-- | Generate C call to the given function in ghc-prim+genPrimCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genPrimCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel+  let lbl = mkCmmCodeLabel ghcInternalUnitId lbl_txt+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate C call to the given function in libc+genLibCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genLibCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- Assume we can call these functions directly, and that they're not in a dynamic library.+  -- TODO: Why is this ok? Under linux this code will be in libm.so+  --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31+  let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate C call to the given function in the RTS+genRTSCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genRTSCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- Assume we can call these functions directly, and that they're not in a dynamic library.+  let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate a real C call to the given address with the given convention+genCCall+  :: BlockId+  -> CmmExpr+  -> ForeignConvention+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genCCall bid addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do+  platform <- getPlatform+  is32Bit <- is32BitPlatform+  let args_hints = zip args (argHints ++ repeat NoHint)+      prom_args = map (maybePromoteCArgToW32 platform) args_hints+  (instrs0, args') <- evalArgs bid prom_args+  instrs1 <- if is32Bit+    then genCCall32 addr conv dest_regs args'+    else genCCall64 addr conv dest_regs args'+  return (instrs0 `appOL` instrs1)++maybePromoteCArgToW32 :: Platform -> (CmmExpr, ForeignHint) -> CmmExpr+maybePromoteCArgToW32 platform (arg, hint)+ | wfrom < wto =+    -- As wto=W32, we only need to handle integer conversions,+    -- never Float -> Double.+    case hint of+      SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg]+      _          -> CmmMachOp (MO_UU_Conv wfrom wto) [arg]+ | otherwise   = arg+ where+   ty = cmmExprType platform arg+   wfrom = typeWidth ty+   wto = W32++genCCall32 :: CmmExpr           -- ^ address of the function to call+           -> ForeignConvention -- ^ calling convention+           -> [CmmFormal]       -- ^ where to put the result+           -> [CmmActual]       -- ^ arguments (of mixed type)+           -> NatM InstrBlock+genCCall32 addr _conv dest_regs args = do+        config <- getConfig+        let platform = ncgPlatform config++            -- If the size is smaller than the word, we widen things (see maybePromoteCArg)+            arg_size_bytes :: CmmType -> Int+            arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))++            roundTo a x | x `mod` a == 0 = x+                        | otherwise = x + a - (x `mod` a)++            push_arg :: CmmActual {-current argument-}+                            -> NatM InstrBlock  -- code++            push_arg  arg -- we don't need the hints on x86+              | isWord64 arg_ty = do+                RegCode64 code r_hi r_lo <- iselExpr64 arg+                delta <- getDeltaNat+                setDeltaNat (delta - 8)+                return (       code `appOL`+                               toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),+                                     PUSH II32 (OpReg r_lo), DELTA (delta - 8),+                                     DELTA (delta-8)]+                    )++              | isFloatType arg_ty || isVecType arg_ty = do+                (reg, code) <- getSomeReg arg+                delta <- getDeltaNat+                setDeltaNat (delta-size)+                return (code `appOL`+                                toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),+                                      DELTA (delta-size),+                                      let addr = AddrBaseIndex (EABaseReg esp)+                                                                EAIndexNone+                                                                (ImmInt 0)+                                          format = cmmTypeFormat arg_ty+                                      in++                                       movInstr config format (OpReg reg) (OpAddr addr)++                                     ]+                               )++              | otherwise = do+                -- Arguments can be smaller than 32-bit, but we still use @PUSH+                -- II32@ - the usual calling conventions expect integers to be+                -- 4-byte aligned.+                massert ((typeWidth arg_ty) <= W32)+                (operand, code) <- getOperand arg+                delta <- getDeltaNat+                setDeltaNat (delta-size)+                return (code `snocOL`+                        PUSH II32 operand `snocOL`+                        DELTA (delta-size))++              where+                 arg_ty = cmmExprType platform arg+                 size = arg_size_bytes arg_ty -- Byte size++        let+            -- Align stack to 16n for calls, assuming a starting stack+            -- alignment of 16n - word_size on procedure entry. Which we+            -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c.+            sizes               = map (arg_size_bytes . cmmExprType platform) (reverse args)+            raw_arg_size        = sum sizes + platformWordSizeInBytes platform+            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size+            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform+++        delta0 <- getDeltaNat+        setDeltaNat (delta0 - arg_pad_size)++        push_codes <- mapM push_arg (reverse args)+        delta <- getDeltaNat+        massert (delta == delta0 - tot_arg_size)++        -- deal with static vs dynamic call targets+        callinsns <-+          case addr of+            CmmLit (CmmLabel lbl)+               -> return $ unitOL (CALL (Left fn_imm) [])+               where fn_imm = ImmCLbl lbl+            _+               -> do { (dyn_r, dyn_c) <- getSomeReg addr+                     ; massert (isWord32 (cmmExprType platform addr))+                     ; return $ dyn_c `snocOL` CALL (Right dyn_r) [] }+        let push_code+                | arg_pad_size /= 0+                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),+                        DELTA (delta0 - arg_pad_size)]+                  `appOL` concatOL push_codes+                | otherwise+                = concatOL push_codes++            call = callinsns `appOL`+                   toOL (+                      (if tot_arg_size == 0 then [] else+                       [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)])+                      +++                      [DELTA delta0]+                   )+        setDeltaNat delta0++        let+            -- assign the results, if necessary+            assign_code []     = nilOL+            assign_code [dest]+              | isVecType ty+              = unitOL (mkRegRegMoveInstr config (cmmTypeFormat ty) xmm0 r_dest)+              | isFloatType ty =+                  -- we assume SSE2+                  let tmp_amode = AddrBaseIndex (EABaseReg esp)+                                                       EAIndexNone+                                                       (ImmInt 0)+                      fmt = floatFormat w+                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA (delta0 - b),+                                   X87Store fmt  tmp_amode,+                                   -- X87Store only supported for the CDECL ABI+                                   -- NB: This code will need to be+                                   -- revisited once GHC does more work around+                                   -- SIGFPE f+                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),+                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA delta0]+              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),+                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]+              | otherwise      = unitOL (MOV (intFormat w)+                                             (OpReg eax)+                                             (OpReg r_dest))+              where+                    ty = localRegType dest+                    w  = typeWidth ty+                    b  = widthInBytes w+                    r_dest_hi = getHiVRegFromLo r_dest+                    r_dest    = getLocalRegReg dest+            assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many)++        return (push_code `appOL`+                call `appOL`+                assign_code dest_regs)++genCCall64 :: CmmExpr           -- ^ address of function to call+           -> ForeignConvention -- ^ calling convention+           -> [CmmFormal]       -- ^ where to put the result+           -> [CmmActual]       -- ^ arguments (of mixed type)+           -> NatM InstrBlock+genCCall64 addr conv dest_regs args = do+    config <- getConfig+    let platform = ncgPlatform config+        word_size = platformWordSizeInBytes platform+        wordFmt = archWordFormat (target32Bit platform)++    -- Compute the code for loading arguments into registers,+    -- returning the leftover arguments that will need to be passed on the stack.+    --+    -- NB: the code for loading references to data into registers is computed+    -- later (in 'pushArgs'), because we don't yet know where the data will be+    -- placed (due to alignment requirements).+    LoadArgs+      { stackArgs       = proper_stack_args+      , stackDataArgs   = stack_data_args+      , usedRegs        = arg_regs_used+      , assignArgsCode  = assign_args_code+      }+      <- loadArgs config args++    let++    -- Pad all arguments and data passed on stack to align them properly.+        (stk_args_with_padding, args_aligned_16) =+          padStackArgs platform (proper_stack_args, stack_data_args)++    -- Align stack to 16n for calls, assuming a starting stack+    -- alignment of 16n - word_size on procedure entry. Which we+    -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c+        need_realign_call = args_aligned_16+    align_call_code <-+      if need_realign_call+      then addStackPadding word_size+      else return nilOL++    -- Compute the code that pushes data to the stack, and also+    -- the code that loads references to that data into registers,+    -- when the data is passed by reference in a register.+    (load_data_refs, push_code) <-+      pushArgs config proper_stack_args stk_args_with_padding++    -- On Windows, leave stack space for the arguments that we are passing+    -- in registers (the so-called shadow space).+    let shadow_space =+          if platformOS platform == OSMinGW32+          then 8 * length (allArgRegs platform)+            -- NB: the shadow store is always 8 * 4 = 32 bytes large,+            -- i.e. the cumulative size of rcx, rdx, r8, r9 (see 'allArgRegs').+          else 0+    shadow_space_code <- addStackPadding shadow_space++    let total_args_size+          = shadow_space+          + sum (map (stackArgSpace platform) stk_args_with_padding)+        real_size =+          total_args_size + if need_realign_call then word_size else 0++    -- End of argument passing.+    --+    -- Next step: emit the appropriate call instruction.+    delta <- getDeltaNat++    let -- The System V AMD64 ABI requires us to set %al to the number of SSE2+        -- registers that contain arguments, if the called routine+        -- is a varargs function.  We don't know whether it's a+        -- varargs function or not, so we have to assume it is.+        --+        -- It's not safe to omit this assignment, even if the number+        -- of SSE2 regs in use is zero.  If %al is larger than 8+        -- on entry to a varargs function, seg faults ensue.+        nb_sse_regs_used = count (isFloatFormat . regWithFormat_format) arg_regs_used+        assign_eax_sse_regs+          = unitOL (MOV II32 (OpImm (ImmInt nb_sse_regs_used)) (OpReg eax))+          -- Note: we do this on Windows as well. It's not entirely clear why+          -- it's needed (the Windows X86_64 calling convention does not+          -- dictate it), but we get segfaults without it.+          --+          -- One test case exhibiting the issue is T20030_test1j;+          -- if you change this, make sure to run it in a loop for a while+          -- with at least -j8 to check.++        -- Live registers we are annotating the call instruction with+        arg_regs = [RegWithFormat eax wordFmt] ++ arg_regs_used++    -- deal with static vs dynamic call targets+    (callinsns,_cconv) <- case addr of+      CmmLit (CmmLabel lbl) ->+        return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv)+      _ -> do+        (dyn_r, dyn_c) <- getSomeReg addr+        return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)++    let call = callinsns `appOL`+               toOL (+                    -- Deallocate parameters after call for ccall+                  (if real_size==0 then [] else+                   [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])+                  +++                  [DELTA (delta + real_size)]+               )+    setDeltaNat (delta + real_size)++    let+        -- assign the results, if necessary+        assign_code []     = nilOL+        assign_code [dest] =+          unitOL $+            mkRegRegMoveInstr config fmt reg r_dest+          where+            reg = if isIntFormat fmt then rax else xmm0+            fmt = cmmTypeFormat rep+            rep = localRegType dest+            r_dest = getRegisterReg platform (CmmLocal dest)+        assign_code _many = panic "genForeignCall.assign_code many"++    return (align_call_code     `appOL`+            push_code           `appOL`+            assign_args_code    `appOL`+            load_data_refs      `appOL`+            shadow_space_code   `appOL`+            assign_eax_sse_regs `appOL`+            call                `appOL`+            assign_code dest_regs)++-- -----------------------------------------------------------------------------+-- Loading arguments into registers for 64-bit C calls.++-- | Information needed to know how to pass arguments in a C call,+-- and in particular how to load them into registers.+data LoadArgs+  = LoadArgs+  -- | Arguments that should be passed on the stack+  { stackArgs     :: [RawStackArg]+  -- | Additional values to store onto the stack.+  , stackDataArgs :: [CmmExpr]+  -- | Which registers are we using for argument passing?+  , usedRegs      :: [RegWithFormat]+  -- | The code to assign arguments to registers used for argument passing.+  , assignArgsCode :: InstrBlock+  }+instance Semigroup LoadArgs where+  LoadArgs a1 d1 r1 j1 <> LoadArgs a2 d2 r2 j2+    = LoadArgs (a1 ++ a2) (d1 ++ d2) (r1 ++ r2) (j1 S.<> j2)+instance Monoid LoadArgs where+  mempty = LoadArgs [] [] [] nilOL++-- | An argument passed on the stack, either directly or by reference.+--+-- The padding information hasn't yet been computed (see 'StackArg').+data RawStackArg+  -- | Pass the argument on the stack directly.+  = RawStackArg { stackArgExpr :: CmmExpr }+  -- | Pass the argument by reference.+  | RawStackArgRef+    { stackRef :: StackRef+       -- ^ is the reference passed in a register, or on the stack?+    , stackRefArgSize :: Int+        -- ^ the size of the data pointed to+    }+  deriving ( Show )++-- | An argument passed on the stack, either directly or by reference,+-- with additional padding information.+data StackArg+  -- | Pass the argument on the stack directly.+  = StackArg+      { stackArgExpr :: CmmExpr+      , stackArgPadding :: Int+        -- ^ padding required (in bytes)+      }+  -- | Pass the argument by reference.+  | StackArgRef+     { stackRef :: StackRef+        -- ^ where the reference is passed+     , stackRefArgSize :: Int+        -- ^ the size of the data pointed to+     , stackRefArgPadding :: Int+       -- ^ padding of the data pointed to+       -- (the reference itself never requires padding)+     }+  deriving ( Show )++-- | Where is a reference to data on the stack passed?+data StackRef+  -- | In a register.+  = InReg Reg+  -- | On the stack.+  | OnStack+  deriving ( Eq, Ord, Show )++newtype Padding = Padding { paddingBytes :: Int }+  deriving ( Show, Eq, Ord )++-- | How much space does this 'StackArg' take up on the stack?+--+-- Only counts the "reference" part for references, not the data it points to.+stackArgSpace :: Platform -> StackArg -> Int+stackArgSpace platform = \case+  StackArg arg padding ->+    argSize platform arg + padding+  StackArgRef { stackRef = ref } ->+    case ref of+      InReg   {} -> 0+      OnStack {} -> 8++-- | Pad arguments, assuming we start aligned to a 16-byte boundary.+--+-- Returns padded arguments, together with whether we end up aligned+-- to a 16-byte boundary.+padStackArgs :: Platform+             -> ([RawStackArg], [CmmExpr])+             -> ([StackArg], Bool)+padStackArgs platform (args0, data_args0) =+  let+    -- Pad the direct args+    (args, align_16_mid) = pad_args True args0++    -- Pad the data section+    (data_args, align_16_end) = pad_args align_16_mid (map RawStackArg data_args0)++    -- Now figure out where the data is placed relative to the direct arguments,+    -- in order to resolve references.+    resolve_args :: [(RawStackArg, Padding)] -> [Padding] -> [StackArg]+    resolve_args [] _ = []+    resolve_args ((stk_arg, Padding pad):rest) pads =+      let (this_arg, pads') =+            case stk_arg of+              RawStackArg arg -> (StackArg arg pad, pads)+              RawStackArgRef ref size -> case pads of+                  Padding arg_pad : rest_pads ->+                    let arg = StackArgRef+                          { stackRef = ref+                          , stackRefArgSize = size+                          , stackRefArgPadding = arg_pad }+                    in (arg, rest_pads)+                  _ -> panic "padStackArgs: no padding info found for StackArgRef"+      in this_arg : resolve_args rest pads'++  in+    ( resolve_args args (fmap snd data_args) +++        [ case data_arg of+            RawStackArg arg -> StackArg arg pad+            RawStackArgRef {} -> panic "padStackArgs: reference in data section"+        | (data_arg, Padding pad) <- data_args+        ]+    , align_16_end )++  where+    pad_args :: Bool -> [RawStackArg] -> ([(RawStackArg, Padding)], Bool)+    pad_args aligned_16 [] = ([], aligned_16)+    pad_args aligned_16 (arg:args)+      | needed_alignment > 16+      -- We don't know if the stack is aligned to 8 (mod 32) or 24 (mod 32).+      -- This makes aligning the stack to a 32 or 64 byte boundary more+      -- complicated, in particular with DELTA.+      = sorry $ unlines+        [ "X86_86 C call: unsupported argument."+        , "  Alignment requirement: " ++ show needed_alignment ++ " bytes."+        , if platformOS platform == OSMinGW32+          then "  The X86_64 NCG does not (yet) support Windows C calls with 256/512 bit vectors."+          else "  The X86_64 NCG cannot (yet) pass 256/512 bit vectors on the stack for C calls."+        , "  Please use the LLVM backend (-fllvm)." ]+      | otherwise+      = let ( rest, final_align_16 ) = pad_args next_aligned_16 args+        in  ( (arg, Padding padding) : rest, final_align_16 )++      where+        needed_alignment = case arg of+          RawStackArg arg   -> argSize platform arg+          RawStackArgRef {} -> platformWordSizeInBytes platform+        padding+          | needed_alignment < 16 || aligned_16+          = 0+          | otherwise+          = 8+        next_aligned_16 = not ( aligned_16 && needed_alignment < 16 )++-- | Load arguments into available registers.+loadArgs :: NCGConfig -> [CmmExpr] -> NatM LoadArgs+loadArgs config args+  | platformOS platform == OSMinGW32+  = evalStateT (loadArgsWin config args) (allArgRegs platform)+  | otherwise+  = evalStateT (loadArgsSysV config args) (allIntArgRegs platform+                                          ,allFPArgRegs  platform)+  where+    platform = ncgPlatform config++-- | Load arguments into available registers (System V AMD64 ABI).+loadArgsSysV :: NCGConfig+             -> [CmmExpr]+             -> StateT ([Reg], [Reg]) NatM LoadArgs+loadArgsSysV _ [] = return mempty+loadArgsSysV config (arg:rest) = do+  (iregs, fregs) <- get+  -- No available registers: pass everything on the stack (shortcut).+  if null iregs && null fregs+  then return $+          LoadArgs+            { stackArgs       = map RawStackArg (arg:rest)+            , stackDataArgs   = []+            , assignArgsCode  = nilOL+            , usedRegs        = []+            }+  else do+    mbReg <-+      if+        | isIntFormat arg_fmt+        , ireg:iregs' <- iregs+        -> do put (iregs', fregs)+              return $ Just ireg+        | isFloatFormat arg_fmt || isVecFormat arg_fmt+        , freg:fregs' <- fregs+        -> do put (iregs, fregs')+              return $ Just freg+        | otherwise+        -> return Nothing+    this_arg <-+      case mbReg of+        Just reg -> do+          assign_code <- lift $ loadArgIntoReg arg reg+          return $+            LoadArgs+                { stackArgs       = [] -- passed in register+                , stackDataArgs   = []+                , assignArgsCode  = assign_code+                , usedRegs        = [RegWithFormat reg arg_fmt]+                }+        Nothing -> do+          return $+            -- No available register for this argument: pass it on the stack.+            LoadArgs+                { stackArgs       = [RawStackArg arg]+                , stackDataArgs   = []+                , assignArgsCode  = nilOL+                , usedRegs        = []+                }+    others <- loadArgsSysV config rest+    return $ this_arg S.<> others++  where+    platform = ncgPlatform config+    arg_fmt = cmmTypeFormat (cmmExprType platform arg)++-- | Compute all things that will need to be pushed to the stack.+--+-- On Windows, an argument passed by reference will require two pieces of data:+--+--  - the reference (returned in the first position)+--  - the actual data (returned in the second position)+computeWinPushArgs :: Platform -> [CmmExpr] -> ([RawStackArg], [CmmExpr])+computeWinPushArgs platform = go+  where+    go :: [CmmExpr] -> ([RawStackArg], [CmmExpr])+    go [] = ([], [])+    go (arg:args) =+      let+        arg_size = argSize platform arg+        (this_arg, add_this_arg)+          | arg_size > 8+          = ( RawStackArgRef OnStack arg_size, (arg :) )+          | otherwise+          = ( RawStackArg arg, id )+        (stk_args, stk_data) = go args+      in+        (this_arg:stk_args, add_this_arg stk_data)++-- | Load arguments into available registers (Windows C X64 calling convention).+loadArgsWin :: NCGConfig -> [CmmExpr] -> StateT [(Reg,Reg)] NatM LoadArgs+loadArgsWin _ [] = return mempty+loadArgsWin config (arg:rest) = do+  regs <- get+  case regs of+    reg:regs' -> do+      put regs'+      this_arg <- lift $ load_arg_win reg+      rest <- loadArgsWin config rest+      return $ this_arg S.<> rest+    [] -> do+      -- No more registers available: pass all (remaining) arguments on the stack.+      let (stk_args, data_args) = computeWinPushArgs platform (arg:rest)+      return $+        LoadArgs+          { stackArgs       = stk_args+          , stackDataArgs   = data_args+          , assignArgsCode  = nilOL+          , usedRegs        = []+          }+  where+    platform = ncgPlatform config+    arg_fmt = cmmTypeFormat $ cmmExprType platform arg+    load_arg_win (ireg, freg)+      | isVecFormat arg_fmt+       -- Vectors are passed by reference.+       -- See Note [The Windows X64 C calling convention].+      = do return $+             LoadArgs+                -- Pass the reference in a register,+                -- and the argument data on the stack.+                { stackArgs       = [RawStackArgRef (InReg ireg) (argSize platform arg)]+                , stackDataArgs   = [arg] -- we don't yet know where the data will reside,+                , assignArgsCode  = nilOL -- so we defer computing the reference and storing it+                                          -- in the register until later+                , usedRegs        = [RegWithFormat ireg II64]+                }+      | otherwise+      = do let arg_reg+                  | isFloatFormat arg_fmt+                  = freg+                  | otherwise+                  = ireg+           assign_code <- loadArgIntoReg arg arg_reg+           -- Recall that, for varargs, we must pass floating-point+           -- arguments in both fp and integer registers.+           let (assign_code', regs')+                | isFloatFormat arg_fmt =+                    ( assign_code `snocOL` MOVD FF64 II64 (OpReg freg) (OpReg ireg),+                      [ RegWithFormat freg FF64+                      , RegWithFormat ireg II64 ])+                | otherwise = (assign_code, [RegWithFormat ireg II64])+           return $+             LoadArgs+               { stackArgs       = [] -- passed in register+               , stackDataArgs   = []+               , assignArgsCode = assign_code'+               , usedRegs = regs'+               }++-- | Load an argument into a register.+--+-- Assumes that the expression does not contain any MachOps,+-- as per Note [Evaluate C-call arguments before placing in destination registers].+loadArgIntoReg :: CmmExpr -> Reg -> NatM InstrBlock+loadArgIntoReg arg reg = do+  when (debugIsOn && loadIntoRegMightClobberOtherReg arg) $ do+    platform <- getPlatform+    massertPpr False $+      vcat [ text "loadArgIntoReg: arg might contain MachOp"+           , text "arg:" <+> pdoc platform arg ]+  arg_code <- getAnyReg arg+  return $ arg_code reg++-- -----------------------------------------------------------------------------+-- Pushing arguments onto the stack for 64-bit C calls.++-- | The size of an argument (in bytes).+--+-- Never smaller than the platform word width.+argSize :: Platform -> CmmExpr -> Int+argSize platform arg =+  max (platformWordSizeInBytes platform) $+    widthInBytes (typeWidth $ cmmExprType platform arg)++-- | Add the given amount of padding on the stack.+addStackPadding :: Int -- ^ padding (in bytes)+                -> NatM InstrBlock+addStackPadding pad_bytes+  | pad_bytes == 0+  = return nilOL+  | otherwise+  = do delta <- getDeltaNat+       setDeltaNat (delta - pad_bytes)+       return $+         toOL [ SUB II64 (OpImm (ImmInt pad_bytes)) (OpReg rsp)+              , DELTA (delta - pad_bytes)+              ]++-- | Push one argument directly to the stack (by value).+--+-- Assumes the current stack pointer fulfills any necessary alignment requirements.+pushArgByValue :: NCGConfig -> CmmExpr -> NatM InstrBlock+pushArgByValue config arg+   -- For 64-bit integer arguments, use PUSH II64.+   --+   -- Note: we *must not* do this for smaller arguments.+   -- For example, if we tried to push an argument such as @CmmLoad addr W32 aln@,+   -- we could end up reading unmapped memory and segfaulting.+   | isIntFormat fmt+   , formatInBytes fmt == 8+   = do+     (arg_op, arg_code) <- getOperand arg+     delta <- getDeltaNat+     setDeltaNat (delta-arg_size)+     return $+       arg_code `appOL` toOL+       [ PUSH II64 arg_op+       , DELTA (delta-arg_size) ]++   | otherwise+   = do+     (arg_reg, arg_code) <- getSomeReg arg+     delta <- getDeltaNat+     setDeltaNat (delta-arg_size)+     return $ arg_code `appOL` toOL+        [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp)+        , DELTA (delta-arg_size)+        , movInstr config fmt (OpReg arg_reg) (OpAddr (spRel platform 0)) ]++    where+      platform = ncgPlatform config+      arg_size = argSize platform arg+      arg_rep = cmmExprType platform arg+      fmt = cmmTypeFormat arg_rep++-- | Load an argument into a register or push it to the stack.+loadOrPushArg :: NCGConfig -> (StackArg, Maybe Int) -> NatM (InstrBlock, InstrBlock)+loadOrPushArg config (stk_arg, mb_off) =+  case stk_arg of+    StackArg arg pad -> do+      push_code <- pushArgByValue config arg+      pad_code  <- addStackPadding pad+      return (nilOL, push_code `appOL` pad_code)+    StackArgRef { stackRef = ref } ->+      case ref of+        -- Pass the reference in a register+        InReg ireg ->+          return (unitOL $ LEA II64 (OpAddr (spRel platform off)) (OpReg ireg), nilOL)+        -- Pass the reference on the stack+        OnStack {} -> do+          tmp <- getNewRegNat II64+          delta <- getDeltaNat+          setDeltaNat (delta-arg_ref_size)+          let push_code = toOL+                [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_ref_size)) (OpReg rsp)+                , DELTA (delta-arg_ref_size)+                , LEA II64 (OpAddr (spRel platform off)) (OpReg tmp)+                , MOV II64 (OpReg tmp) (OpAddr (spRel platform 0)) ]+          return (nilOL, push_code)+      where off = expectJust mb_off+    where+      arg_ref_size = 8 -- passing a reference to the argument+      platform = ncgPlatform config++-- | Push arguments to the stack, right to left.+--+-- On Windows, some arguments may need to be passed by reference,+-- which requires separately passing the data and the reference.+-- See Note [The Windows X64 C calling convention].+pushArgs :: NCGConfig+         -> [RawStackArg]+            -- ^ arguments proper (i.e. don't include the data for arguments passed by reference)+         -> [StackArg]+            -- ^ arguments we are passing on the stack+         -> NatM (InstrBlock, InstrBlock)+pushArgs config proper_args all_stk_args+  = do { let+            vec_offs :: [Maybe Int]+            vec_offs+              | platformOS platform == OSMinGW32+              = go stack_arg_size all_stk_args+              | otherwise+              = repeat Nothing++    ---------------------+    -- Windows-only code++            -- Size of the arguments we are passing on the stack, counting only+            -- the reference part for arguments passed by reference.+            stack_arg_size = 8 * count not_in_reg proper_args+            not_in_reg (RawStackArg {}) = True+            not_in_reg (RawStackArgRef { stackRef = ref }) =+              case ref of+                InReg {} -> False+                OnStack {} -> True++            -- Check an offset is valid (8-byte aligned), for assertions.+            ok off = off `rem` 8 == 0++            -- Tricky code: compute the stack offset to the vector data+            -- for this argument.+            --+            -- If you're confused, Note [The Windows X64 C calling convention]+            -- contains a helpful diagram.+            go :: Int -> [StackArg] -> [Maybe Int]+            go _ [] = []+            go off (stk_arg:args) =+              assertPpr (ok off) (text "unaligned offset:" <+> ppr off) $+              case stk_arg of+                StackArg {} ->+                  -- Only account for the stack pointer movement.+                  let off' = off - stackArgSpace platform stk_arg+                  in Nothing : go off' args+                StackArgRef+                  { stackRefArgSize    = data_size+                  , stackRefArgPadding = data_pad } ->+                  assertPpr (ok data_size) (text "unaligned data size:" <+> ppr data_size) $+                  assertPpr (ok data_pad) (text "unaligned data padding:" <+> ppr data_pad) $+                  let off' = off+                        -- Next piece of data is after the data for this reference+                           + data_size + data_pad+                        -- ... and account for the stack pointer movement.+                           - stackArgSpace platform stk_arg+                  in Just (data_pad + off) : go off' args++    -- end of Windows-only code+    ----------------------------++         -- Push the stack arguments (right to left),+         -- including both the reference and the data for arguments passed by reference.+       ; (load_regs, push_args) <- foldMapM (loadOrPushArg config) (reverse $ zip all_stk_args vec_offs)+       ; return (load_regs, push_args) }+  where+    platform = ncgPlatform config++{- Note [The Windows X64 C calling convention]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are a few facts about the Windows X64 C calling convention that+are important:++  - any argument larger than 8 bytes must be passed by reference,+    and arguments smaller than 8 bytes are padded to 8 bytes.++  - the first four arguments are passed in registers:+      - floating-point scalar arguments are passed in %xmm0, %xmm1, %xmm2, %xmm3+      - other arguments are passed in %rcx, %rdx, %r8, %r9+        (this includes vector arguments, passed by reference)++    For variadic functions, it is additionally expected that floating point+    scalar arguments are copied to the corresponding integer register, e.g.+    the data in xmm2 should also be copied to r8.++    There is no requirement about setting %al like there is for the+    System V AMD64 ABI.++  - subsequent arguments are passed on the stack.++There are also alignment requirements:++  - the data for vectors must be aligned to the size of the vector,+    e.g. a 32 byte vector must be aligned on a 32 byte boundary,++  - the call instruction must be aligned to 16 bytes.+  (This differs from the System V AMD64 ABI, which mandates that the call+  instruction must be aligned to 32 bytes if there are any 32 byte vectors+  passed on the stack.)++This motivates our handling of vector values. Suppose we have a function call+with many arguments, several of them being vectors. We proceed as follows:++ - Add some padding, if necessary, to ensure the stack, when executing the call+    instruction, is 16-byte aligned. Whether this padding is necessary depends+    on what happens next. (Recall also that we start off at 8 (mod 16) alignment,+    as per Note [Stack Alignment on X86] in rts/StgCRun.c)+  - Push all the vectors to the stack first, adding padding after each one+    if necessary.+  - Then push the arguments:+      - for non-vectors, proceed as usual,+      - for vectors, push the address of the vector data we pushed above.+  - Then assign the registers:+      - for non-vectors, proceed as usual,+      - for vectors, store the address in a general-purpose register, as opposed+        to storing the data in an xmm register.++For a concrete example, suppose we have a call of the form:++  f x1 x2 x3 x4 x5 x6 x7++in which:++  - x2, x3, x5 and x7 are 16 byte vectors+  - the other arguments are all 8 byte wide++Now, x1, x2, x3, x4 will get passed in registers, except that we pass+x2 and x3 by reference, because they are vectors. We proceed as follows:++  - push the vectors to the stack: x7, x5, x3, x2 (in that order)+  - push the stack arguments in order: addr(x7), x6, addr(x5)+  - load the remaining arguments into registers: x4, addr(x3), addr(x2), x1++The tricky part is to get the right offsets for the addresses of the vector+data. The following visualisation will hopefully clear things up:++                                  ┌──┐+                                  │▓▓│ ─── padding to align the call instruction+                      ╭─╴         ╞══╡     (ensures Sp, below, is 16-byte aligned)+                      │           │  │+                      │  x7  ───╴ │  │+                      │           ├──┤+                      │           │  │+                      │  x5  ───╴ │  │+                      │           ├──┤+     vector data  ────┤           │  │+(individually padded) │  x3  ───╴ │  │+                      │           ├──┤+                      │           │  │+                      │  x2  ───╴ │  │+                      │           ├┄┄┤+                      │           │▓▓│ ─── padding to align x2 to 16 bytes+               ╭─╴    ╰─╴         ╞══╡+               │    addr(x7) ───╴ │  │    ╭─ from here: x7 is +64+               │                  ├──┤ ╾──╯    = 64 (position of x5)+     stack  ───┤         x6  ───╴ │  │         + 16 (size of x5) + 0 (padding of x7)+   arguments   │                  ├──┤         - 2 * 8 (x7 is 2 arguments higher than x5)+               │    addr(x5) ───╴ │  │+               ╰─╴            ╭─╴ ╞══╡ ╾─── from here:+                              │   │  │       - x2 is +32 = 24 (stack_arg_size) + 8 (padding of x2)+                   shadow  ───┤   │  │       - x3 is +48 = 32 (position of x2) + 16 (size of x2) + 0 (padding of x3)+                    space     │   │  │       - x5 is +64 = 48 (position of x3) + 16 (size of x3) + 0 (padding of x5)+                              │   │  │+                              ╰─╴ └──┘ ╾─── Sp++This is all tested in the simd013 test.+-}++-- -----------------------------------------------------------------------------+-- Generating a table-branch++{-+Note [Sub-word subtlety during jump-table indexing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Offset the index by the start index of the jump table.+It's important that we do this *before* the widening below. To see+why, consider a switch with a sub-word, signed discriminant such as:++    switch [-5...+2] x::I16 {+        case -5: ...+        ...+        case +2: ...+    }++Consider what happens if we offset *after* widening in the case that+x=-4:++                                         // x == -4 == 0xfffc::I16+    indexWidened = UU_Conv(x);           // == 0xfffc::I64+    indexExpr    = indexWidened - (-5);  // == 0x10000::I64++This index is clearly nonsense given that the jump table only has+eight entries.++By contrast, if we widen *after* we offset then we get the correct+index (1),++                                         // x == -4 == 0xfffc::I16+    indexOffset  = x - (-5);             // == 1::I16+    indexExpr    = UU_Conv(indexOffset); // == 1::I64++See #21186.+-}++genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock++genSwitch expr targets = do+  config <- getConfig+  let platform = ncgPlatform config+      expr_w = cmmExprWidth platform expr+      indexExpr0 = cmmOffset platform expr offset+      -- We widen to a native-width register because we cannot use arbitrary sizes+      -- in x86 addressing modes.+      -- See Note [Sub-word subtlety during jump-table indexing].+      indexExpr = CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+  if ncgPIC config+  then do+        (reg,e_code) <- getNonClobberedReg indexExpr+           -- getNonClobberedReg because it needs to survive across t_code+        lbl <- getNewLabelNat+        let is32bit = target32Bit platform+            os = platformOS platform+            -- Might want to use .rodata.<function we're in> instead, but as+            -- long as it's something unique it'll work out since the+            -- references to the jump table are in the appropriate section.+            rosection = case os of+              -- on Mac OS X/x86_64, put the jump table in the text section to+              -- work around a limitation of the linker.+              -- ld64 is unable to handle the relocations for+              --     .quad L1 - L0+              -- if L0 is not preceded by a non-anonymous label in its section.+              OSDarwin | not is32bit -> Section Text lbl+              _ -> Section ReadOnlyData lbl+        dynRef <- cmmMakeDynamicReference config DataReference lbl+        (tableReg,t_code) <- getSomeReg $ dynRef+        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)+                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))++        return $ e_code `appOL` t_code `appOL` toOL [+                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),+                                JMP_TBL (OpReg tableReg) ids rosection lbl+                       ]+  else do+        (reg,e_code) <- getSomeReg indexExpr+        lbl <- getNewLabelNat+        let is32bit = target32Bit platform+        if is32bit+          then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))+                   jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl+               in return $ e_code `appOL` unitOL jmp_code+          else do+            -- See Note [%rip-relative addressing on x86-64].+            tableReg <- getNewRegNat (intFormat (platformWordWidth platform))+            targetReg <- getNewRegNat (intFormat (platformWordWidth platform))+            let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))+                fmt = archWordFormat is32bit+                code = e_code `appOL` toOL+                    [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)+                    , MOV fmt op (OpReg targetReg)+                    , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl+                    ]+            return code+  where+    (offset, blockIds) = switchTargetsToTable targets+    ids = map (fmap DestBlockId) blockIds++generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)+generateJumpTableForInstr config (JMP_TBL _ ids section lbl)+    = let getBlockId (DestBlockId id) = id+          getBlockId _ = panic "Non-Label target in Jump Table"+          blockIds = map (fmap getBlockId) ids+      in Just (createJumpTable config blockIds section lbl)+generateJumpTableForInstr _ _ = Nothing++createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel+                -> GenCmmDecl (Alignment, RawCmmStatics) h g+createJumpTable config ids section lbl+    = let jumpTable+            | ncgPIC config =+                  let ww = ncgWordWidth config+                      jumpTableEntryRel Nothing+                          = CmmStaticLit (CmmInt 0 ww)+                      jumpTableEntryRel (Just blockid)+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)+                          where blockLabel = blockLbl blockid+                  in map jumpTableEntryRel ids+            | otherwise = map (jumpTableEntry config) ids+      in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)++extractUnwindPoints :: [Instr] -> [UnwindPoint]+extractUnwindPoints instrs =+    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]++-- -----------------------------------------------------------------------------+-- 'condIntReg' and 'condFltReg': condition codes into registers++-- Turn those condition codes into integers now (when they appear on+-- the right hand side of an assignment).+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.++condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register++condIntReg cond x y = do+  CondCode _ cond cond_code <- condIntCode cond x y+  tmp <- getNewRegNat II8+  let+        code dst = cond_code `appOL` toOL [+                    SETCC cond (OpReg tmp),+                    MOVZxL II8 (OpReg tmp) (OpReg dst)+                  ]+  return (Any II32 code)+++-- Note [SSE Parity Checks]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- We have to worry about unordered operands (eg. comparisons+-- against NaN).  If the operands are unordered, the comparison+-- sets the parity flag, carry flag and zero flag.+-- All comparisons are supposed to return false for unordered+-- operands except for !=, which returns true.+--+-- Optimisation: we don't have to test the parity flag if we+-- know the test has already excluded the unordered case: eg >+-- and >= test for a zero carry flag, which can only occur for+-- ordered operands.+--+-- By reversing comparisons we can avoid testing the parity+-- for < and <= as well. If any of the arguments is an NaN we+-- return false either way. If both arguments are valid then+-- x <= y  <->  y >= x  holds. So it's safe to swap these.+--+-- We invert the condition inside getRegister'and  getCondCode+-- which should cover all invertable cases.+-- All other functions translating FP comparisons to assembly+-- use these to two generate the comparison code.+--+-- As an example consider a simple check:+--+-- func :: Float -> Float -> Int+-- func x y = if x < y then 1 else 0+--+-- Which in Cmm gives the floating point comparison.+--+--  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;+--+-- We used to compile this to an assembly code block like this:+-- _c2gh:+--  ucomiss %xmm2,%xmm1+--  jp _c2gf+--  jb _c2gg+--  jmp _c2gf+--+-- Where we have to introduce an explicit+-- check for unordered results (using jmp parity):+--+-- We can avoid this by exchanging the arguments and inverting the direction+-- of the comparison. This results in the sequence of:+--+--  ucomiss %xmm1,%xmm2+--  ja _c2g2+--  jmp _c2g1+--+-- Removing the jump reduces the pressure on the branch prediction system+-- and plays better with the uOP cache.++condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register+condFltReg is32Bit cond x y = condFltReg_sse2+ where+++  condFltReg_sse2 = do+    CondCode _ cond cond_code <- condFltCode cond x y+    tmp1 <- getNewRegNat (archWordFormat is32Bit)+    tmp2 <- getNewRegNat (archWordFormat is32Bit)+    let -- See Note [SSE Parity Checks]+        code dst =+           cond_code `appOL`+             (case cond of+                NE  -> or_unordered dst+                GU  -> plain_test   dst+                GEU -> plain_test   dst+                -- Use ASSERT so we don't break releases if these creep in.+                LTT -> assertPpr False (text "Should have been turned into >") $+                       and_ordered  dst+                LE  -> assertPpr False (text "Should have been turned into >=") $+                       and_ordered  dst+                _   -> and_ordered  dst)++        plain_test dst = toOL [+                    SETCC cond (OpReg tmp1),+                    MOVZxL II8 (OpReg tmp1) (OpReg dst)+                 ]+        or_unordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC PARITY (OpReg tmp2),+                    OR II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+        and_ordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC NOTPARITY (OpReg tmp2),+                    AND II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+    return (Any II32 code)+++-- -----------------------------------------------------------------------------+-- 'trivial*Code': deal with trivial instructions++-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.+-- Only look for constants on the right hand side, because that's+-- where the generic optimizer will have put them.++-- Similarly, for unary instructions, we don't have to worry about+-- matching an StInt as the argument, because genericOpt will already+-- have handled the constant-folding.+++{-+The Rules of the Game are:++* You cannot assume anything about the destination register dst;+  it may be anything, including a fixed reg.++* You may compute an operand into a fixed reg, but you may not+  subsequently change the contents of that fixed reg.  If you+  want to do so, first copy the value either to a temporary+  or into dst.  You are free to modify dst even if it happens+  to be a fixed reg -- that's not your problem.++* You cannot assume that a fixed reg will stay live over an+  arbitrary computation.  The same applies to the dst reg.++* Temporary regs obtained from getNewRegNat are distinct from+  each other and from all other regs, and stay live over+  arbitrary computations.++--------------------++SDM's version of The Rules:++* If getRegister returns Any, that means it can generate correct+  code which places the result in any register, period.  Even if that+  register happens to be read during the computation.++  Corollary #1: this means that if you are generating code for an+  operation with two arbitrary operands, you cannot assign the result+  of the first operand into the destination register before computing+  the second operand.  The second operand might require the old value+  of the destination register.++  Corollary #2: A function might be able to generate more efficient+  code if it knows the destination register is a new temporary (and+  therefore not read by any of the sub-computations).++* If getRegister returns Any, then the code it generates may modify only:+        (a) fresh temporaries+        (b) the destination register+        (c) known registers (eg. %ecx is used by shifts)+  In particular, it may *not* modify global registers, unless the global+  register happens to be the destination register.+-}++trivialCode :: Width -> (Operand -> Operand -> Instr)+            -> Maybe (Operand -> Operand -> Instr)+            -> CmmExpr -> CmmExpr -> NatM Register+trivialCode width instr m a b+    = do platform <- getPlatform+         trivialCode' platform width instr m a b++trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr)+             -> Maybe (Operand -> Operand -> Instr)+             -> CmmExpr -> CmmExpr -> NatM Register+trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b+  | is32BitLit platform lit_a = do+  b_code <- getAnyReg b+  let+       code dst+         = b_code dst `snocOL`+           revinstr (OpImm (litToImm lit_a)) (OpReg dst)+  return (Any (intFormat width) code)++trivialCode' _ width instr _ a b+  = genTrivialCode (intFormat width) (\op2 -> instr op2 . OpReg) a b++-- This is re-used for floating pt instructions too.+genTrivialCode :: Format -> (Operand -> Reg -> Instr)+               -> CmmExpr -> CmmExpr -> NatM Register+genTrivialCode rep instr a b = do+  (b_op, b_code) <- getNonClobberedOperand b+  a_code <- getAnyReg a+  tmp <- getNewRegNat rep+  let+     -- We want the value of 'b' to stay alive across the computation of 'a'.+     -- But, we want to calculate 'a' straight into the destination register,+     -- because the instruction only has two operands (dst := dst `op` src).+     -- The troublesome case is when the result of 'b' is in the same register+     -- as the destination 'reg'.  In this case, we have to save 'b' in a+     -- new temporary across the computation of 'a'.+     code dst+        | dst `regClashesWithOp` b_op =+                b_code `appOL`+                unitOL (MOV rep b_op (OpReg tmp)) `appOL`+                a_code dst `snocOL`+                instr (OpReg tmp) dst+        | otherwise =+                b_code `appOL`+                a_code dst `snocOL`+                instr b_op dst+  return (Any rep code)++regClashesWithOp :: Reg -> Operand -> Bool+reg `regClashesWithOp` OpReg reg2   = reg == reg2+reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)+_   `regClashesWithOp` _            = False++-- | Generate code for a fused multiply-add operation, of the form @± x * y ± z@,+-- with 3 operands (FMA3 instruction set).+genFMA3Code :: Length+            -> Width+            -> FMASign+            -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register+genFMA3Code l w signs x y z = do+  config <- getConfig+  -- For the FMA instruction, we want to compute x * y + z+  --+  -- There are three possible instructions we could emit:+  --+  --   - fmadd213 z y x, result in x, z can be a memory address+  --   - fmadd132 x z y, result in y, x can be a memory address+  --   - fmadd231 y x z, result in z, y can be a memory address+  --+  -- This suggests two possible optimisations:+  --+  --   - OPTIMISATION 1+  --     If one argument is an address, use the instruction that allows+  --     a memory address in that position.+  --+  --   - OPTIMISATION 2+  --     If one argument is in a fixed register, use the instruction that puts+  --     the result in that same register.+  --+  -- Currently we follow neither of these optimisations,+  -- opting to always use fmadd213 for simplicity.+  --+  -- We would like to compute the result directly into the requested register.+  -- To do so we must first compute `x` into the destination register. This is+  -- only possible if the other arguments don't use the destination register.+  -- We check for this and if there is a conflict we move the result only after+  -- the computation. See #24496 how this went wrong in the past.+  let rep+        | l == 1+        = floatFormat w+        | otherwise+        = vecFormat (cmmVec l $ cmmFloat w)+  (y_reg, y_code) <- getNonClobberedReg y+  (z_op, z_code) <- getNonClobberedOperand z+  x_code <- getAnyReg x+  x_tmp <- getNewRegNat rep+  let+     fma213 = FMA3 rep signs FMA213++     code, code_direct, code_mov :: Reg -> InstrBlock+     -- Ideal: Compute the result directly into dst+     code_direct dst = x_code dst `snocOL`+                       fma213 z_op y_reg dst+     -- Fallback: Compute the result into a tmp reg and then move it.+     code_mov dst    = x_code x_tmp `snocOL`+                       fma213 z_op y_reg x_tmp `snocOL`+                       mkRegRegMoveInstr config rep x_tmp dst++     code dst =+        y_code `appOL`+        z_code `appOL`+        ( if arg_regs_conflict then code_mov dst else code_direct dst )++      where++        arg_regs_conflict =+          y_reg == dst ||+          case z_op of+            OpReg z_reg -> z_reg == dst+            OpAddr amode -> dst `elem` addrModeRegs amode+            OpImm {} -> False++  -- NB: Computing the result into a desired register using Any can be tricky.+  -- So for now, we keep it simple. (See #24496).+  return (Any rep code)++-----------++trivialUCode :: Format -> (Operand -> Instr)+             -> CmmExpr -> NatM Register+trivialUCode rep instr x = do+  x_code <- getAnyReg x+  let+     code dst =+        x_code dst `snocOL`+        instr (OpReg dst)+  return (Any rep code)++-----------+++trivialFCode_sse2 :: Width -> (Format -> Operand -> Reg -> Instr)+                  -> CmmExpr -> CmmExpr -> NatM Register+trivialFCode_sse2 ty instr x y+    = genTrivialCode format (instr format) x y+    where format = floatFormat ty+++--------------------------------------------------------------------------------+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP from to x =  coerce_sse2+ where++   coerce_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD+                             n -> panic $ "coerceInt2FP.sse: unhandled width ("+                                         ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat from) x_op dst+     return (Any (floatFormat to) code)+        -- works even if the destination rep is <II32++--------------------------------------------------------------------------------+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int from to x =  coerceFP2Int_sse2+ where+   coerceFP2Int_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;+                               n -> panic $ "coerceFP2Init.sse: unhandled width ("+                                           ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat to) x_op dst+     return (Any (intFormat to) code)+         -- works even if the destination rep is <II32+++--------------------------------------------------------------------------------+coerceFP2FP :: Width -> CmmExpr -> NatM Register+coerceFP2FP to x = do+  (x_reg, x_code) <- getSomeReg x+  let+        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;+                                     n -> panic $ "coerceFP2FP: unhandled width ("+                                                 ++ show n ++ ")"+        code dst = x_code `snocOL` opc x_reg dst+  return (Any ( floatFormat to) code)++--------------------------------------------------------------------------------++sse2NegCode :: Width -> CmmExpr -> NatM Register+sse2NegCode w x = do+  let fmt = floatFormat w+  x_code <- getAnyReg x+  -- This is how gcc does it, so it can't be that bad:+  let+    const = case fmt of+      FF32 -> CmmInt 0x80000000 W32+      FF64 -> CmmInt 0x8000000000000000 W64+      x@II8  -> wrongFmt x+      x@II16 -> wrongFmt x+      x@II32 -> wrongFmt x+      x@II64 -> wrongFmt x+      x@(VecFormat {}) -> wrongFmt x++      where+        wrongFmt x = panic $ "sse2NegCode: " ++ show x+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const+  tmp <- getNewRegNat fmt+  let+    code dst = x_code dst `appOL` amode_code `appOL` toOL [+        MOV fmt (OpAddr amode) (OpReg tmp),+        XOR fmt (OpReg tmp) (OpReg dst)+        ]+  --+  return (Any fmt code)++needLlvm :: MachOp -> NatM a+needLlvm mop =+  sorry $ unlines [ "Unsupported vector instruction for the native code generator:"+                  , show mop+                  , "Please use -fllvm." ]++incorrectOperands :: NatM a+incorrectOperands = sorry "Incorrect number of operands"++invalidConversion :: Width -> Width -> NatM a+invalidConversion from to =+  sorry $ "Invalid conversion operation from " ++ show from ++ " to " ++ show to++-- | This works on the invariant that all jumps in the given blocks are required.+--   Starting from there we try to make a few more jumps redundant by reordering+--   them.+--   We depend on the information in the CFG to do so so without a given CFG+--   we do nothing.+invertCondBranches :: Maybe CFG  -- ^ CFG if present+                   -> LabelMap a -- ^ Blocks with info tables+                   -> [NatBasicBlock Instr] -- ^ List of basic blocks+                   -> [NatBasicBlock Instr]+invertCondBranches Nothing _       bs = bs+invertCondBranches (Just cfg) keep bs =+    invert bs+  where+    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]+    invert (BasicBlock lbl1 ins:b2@(BasicBlock lbl2 _):bs)+      | --pprTrace "Block" (ppr lbl1) True,+        Just (jmp1,jmp2) <- last2 ins+      , JXX cond1 target1 <- jmp1+      , target1 == lbl2+      --, pprTrace "CutChance" (ppr b1) True+      , JXX ALWAYS target2 <- jmp2+      -- We have enough information to check if we can perform the inversion+      -- TODO: We could also check for the last asm instruction which sets+      -- status flags instead. Which I suspect is worse in terms of compiler+      -- performance, but might be applicable to more cases+      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg+      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg+      -- Both jumps come from the same cmm statement+      , transitionSource edgeInfo1 == transitionSource edgeInfo2+      , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1++      --Int comparisons are invertable+      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch+      , Just _ <- maybeIntComparison op+      , Just invCond <- maybeInvertCond cond1++      --Swap the last two jumps, invert the conditional jumps condition.+      = let jumps =+              case () of+                -- We are free the eliminate the jmp. So we do so.+                _ | not (mapMember target1 keep)+                    -> [JXX invCond target2]+                -- If the conditional target is unlikely we put the other+                -- target at the front.+                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1+                    -> [JXX invCond target2, JXX ALWAYS target1]+                -- Keep things as-is otherwise+                  | otherwise+                    -> [jmp1, jmp2]+        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $+           (BasicBlock lbl1+            (dropTail 2 ins ++ jumps))+            : invert (b2:bs)+    invert (b:bs) = b : invert bs+    invert [] = []++genAtomicRMW+  :: BlockId+  -> Width+  -> AtomicMachOp+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (InstrBlock, Maybe BlockId)+genAtomicRMW bid width amop dst addr n = do+    Amode amode addr_code <-+        if amop `elem` [AMO_Add, AMO_Sub]+        then getAmode addr+        else getSimpleAmode addr  -- See genForeignCall for MO_Cmpxchg+    arg <- getNewRegNat format+    arg_code <- getAnyReg n+    platform <- ncgPlatform <$> getConfig++    let dst_r    = getRegisterReg platform  (CmmLocal dst)+    (code, lbl) <- op_code dst_r arg amode+    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)+  where+    -- Code for the operation+    op_code :: Reg       -- Destination reg+            -> Reg       -- Register containing argument+            -> AddrMode  -- Address of location to mutate+            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId+    op_code dst_r arg amode = do+        case amop of+          -- In the common case where dst_r is a virtual register the+          -- final move should go away, because it's the last use of arg+          -- and the first use of dst_r.+          AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))+                                     , MOV format (OpReg arg) (OpReg dst_r)+                                     ], bid)+          AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)+                                     , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                     , MOV format (OpReg arg) (OpReg dst_r)+                                     ], bid)+          -- In these cases we need a new block id, and have to return it so+          -- that later instruction selection can reference it.+          AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)+          AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst+                                                      , NOT format dst+                                                      ])+          AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)+          AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)+      where+        -- Simulate operation that lacks a dedicated instruction using+        -- cmpxchg.+        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)+                     -> NatM (OrdList Instr, BlockId)+        cmpxchg_code instrs = do+            lbl1 <- getBlockIdNat+            lbl2 <- getBlockIdNat+            tmp <- getNewRegNat format++            --Record inserted blocks+            --  We turn A -> B into A -> A' -> A'' -> B+            --  with a self loop on A'.+            addImmediateSuccessorNat bid lbl1+            addImmediateSuccessorNat lbl1 lbl2+            updateCfgNat (addWeightEdge lbl1 lbl1 0)++            return $ (toOL+                [ MOV format (OpAddr amode) (OpReg eax)+                , JXX ALWAYS lbl1+                , NEWBLOCK lbl1+                  -- Keep old value so we can return it:+                , MOV format (OpReg eax) (OpReg dst_r)+                , MOV format (OpReg eax) (OpReg tmp)+                ]+                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL+                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))+                , JXX NE lbl1+                -- See Note [Introducing cfg edges inside basic blocks]+                -- why this basic block is required.+                , JXX ALWAYS lbl2+                , NEWBLOCK lbl2+                ],+                lbl2)+    format = intFormat width++-- | Count trailing zeroes+genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)+genCtz bid width dst src = do+  is32Bit <- is32BitPlatform+  if is32Bit && width == W64+    then genCtz64_32 bid dst src+    else (,Nothing) <$> genCtzGeneric width dst src++-- | Count trailing zeroes+--+-- 64-bit width on 32-bit architecture+genCtz64_32+  :: BlockId+  -> LocalReg+  -> CmmExpr+  -> NatM (InstrBlock, Maybe BlockId)+genCtz64_32 bid dst src = do+  RegCode64 vcode rhi rlo <- iselExpr64 src+  let dst_r = getLocalRegReg dst+  lbl1 <- getBlockIdNat+  lbl2 <- getBlockIdNat+  tmp_r <- getNewRegNat II64++  -- New CFG Edges:+  --  bid -> lbl2+  --  bid -> lbl1 -> lbl2+  --  We also changes edges originating at bid to start at lbl2 instead.+  weights <- getCfgWeights+  updateCfgNat (addWeightEdge bid lbl1 110 .+                addWeightEdge lbl1 lbl2 110 .+                addImmediateSuccessor weights bid lbl2)++  -- The following instruction sequence corresponds to the pseudo-code+  --+  --  if (src) {+  --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);+  --  } else {+  --    dst = 64;+  --  }+  let instrs = vcode `appOL` toOL+           ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)+            , OR       II32 (OpReg rlo)         (OpReg tmp_r)+            , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)+            , JXX EQQ    lbl2+            , JXX ALWAYS lbl1++            , NEWBLOCK   lbl1+            , BSF     II32 (OpReg rhi)         dst_r+            , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)+            , BSF     II32 (OpReg rlo)         tmp_r+            , CMOV NE II32 (OpReg tmp_r)       dst_r+            , JXX ALWAYS lbl2++            , NEWBLOCK   lbl2+            ])+  return (instrs, Just lbl2)++-- | Count trailing zeroes+--+-- Generic case (width <= word size)+genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genCtzGeneric width dst src = do+  code_src <- getAnyReg src+  config <- getConfig+  let bw = widthInBits width+  let dst_r = getLocalRegReg dst+  if ncgBmiVersion config >= Just BMI2+  then do+      src_r <- getNewRegNat (intFormat width)+      let instrs = appOL (code_src src_r) $ case width of+              W8 -> toOL+                  [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)+                  , TZCNT II32 (OpReg src_r) dst_r+                  ]+              W16 -> toOL+                  [ TZCNT  II16 (OpReg src_r) dst_r+                  , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)+                  ]+              _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r+      return instrs+  else do+      -- The following insn sequence makes sure 'ctz 0' has a defined value.+      -- starting with Haswell, one could use the TZCNT insn instead.+      let format = if width == W8 then II16 else intFormat width+      src_r <- getNewRegNat format+      tmp_r <- getNewRegNat format+      let instrs = code_src src_r `appOL` toOL+               ([ MOVZxL  II8    (OpReg src_r)       (OpReg src_r) | width == W8 ] +++                [ BSF     format (OpReg src_r)       tmp_r+                , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)+                , CMOV NE format (OpReg tmp_r)       dst_r+                ]) -- NB: We don't need to zero-extend the result for the+                   -- W8/W16 cases because the 'MOV' insn already+                   -- took care of implicitly clearing the upper bits+      return instrs++++-- | Copy memory+--+-- Unroll memcpy calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemcpy).  Otherwise, call C's memcpy.+genMemCpy+  :: BlockId+  -> Int+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genMemCpy bid align dst src arg_n = do++  let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n]++  case arg_n of+    CmmLit (CmmInt n _) -> do+      -- try to inline it+      mcode <- genMemCpyInlineMaybe align dst src n+      -- if it didn't inline, call the C function+      case mcode of+        Nothing -> libc_memcpy+        Just c  -> pure c++    -- not a literal size argument: call the C function+    _ -> libc_memcpy++++genMemCpyInlineMaybe+  :: Int+  -> CmmExpr+  -> CmmExpr+  -> Integer+  -> NatM (Maybe InstrBlock)+genMemCpyInlineMaybe align dst src n = do+  config <- getConfig+  let+    platform     = ncgPlatform config+    maxAlignment = wordAlignment platform+                   -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+++  -- The size of each move, in bytes.+  let sizeBytes :: Integer+      sizeBytes = fromIntegral (formatInBytes format)++  -- The number of instructions we will generate (approx). We need 2+  -- instructions per move.+  let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)++      go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr+      go dst src tmp i+          | i >= sizeBytes =+              unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - sizeBytes)+          -- Deal with remaining bytes.+          | i >= 4 =  -- Will never happen on 32-bit+              unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 4)+          | i >= 2 =+              unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV    II16  (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 2)+          | i >= 1 =+              unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV    II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 1)+          | otherwise = nilOL+        where+          src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone+                       (ImmInteger (n - i))++          dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone+                       (ImmInteger (n - i))++  if insns > fromIntegral (ncgInlineThresholdMemcpy config)+    then pure Nothing+    else do+      code_dst <- getAnyReg dst+      dst_r <- getNewRegNat format+      code_src <- getAnyReg src+      src_r <- getNewRegNat format+      tmp_r <- getNewRegNat format+      pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL`+                      go dst_r src_r tmp_r (fromInteger n)++-- | Set memory to the given byte+--+-- Unroll memset calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemset).  Otherwise, call C's memset.+genMemSet+  :: BlockId+  -> Int+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genMemSet bid align dst arg_c arg_n = do++  let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n]++  case (arg_c,arg_n) of+    (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do+      -- try to inline it+      mcode <- genMemSetInlineMaybe align dst c n+      -- if it didn't inline, call the C function+      case mcode of+        Nothing -> libc_memset+        Just c  -> pure c++    -- not literal size arguments: call the C function+    _ -> libc_memset++genMemSetInlineMaybe+  :: Int+  -> CmmExpr+  -> Integer+  -> Integer+  -> NatM (Maybe InstrBlock)+genMemSetInlineMaybe align dst c n = do+  config <- getConfig+  let+    platform = ncgPlatform config+    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+    c2 = c `shiftL` 8 .|. c+    c4 = c2 `shiftL` 16 .|. c2+    c8 = c4 `shiftL` 32 .|. c4++    -- The number of instructions we will generate (approx). We need 1+    -- instructions per move.+    insns = (n + sizeBytes - 1) `div` sizeBytes++    -- The size of each move, in bytes.+    sizeBytes :: Integer+    sizeBytes = fromIntegral (formatInBytes format)++    -- Depending on size returns the widest MOV instruction and its+    -- width.+    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)+    gen4 addr size+        | size >= 4 =+            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)+        | size >= 2 =+            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)+        | size >= 1 =+            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)+        | otherwise = (nilOL, 0)++    -- Generates a 64-bit wide MOV instruction from REG to MEM.+    gen8 :: AddrMode -> Reg -> InstrBlock+    gen8 addr reg8byte =+      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))++    -- Unrolls memset when the widest MOV is <= 4 bytes.+    go4 :: Reg -> Integer -> InstrBlock+    go4 dst left =+      if left <= 0 then nilOL+      else curMov `appOL` go4 dst (left - curWidth)+      where+        possibleWidth = min left sizeBytes+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))+        (curMov, curWidth) = gen4 dst_addr possibleWidth++    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg+    -- argument). Falls back to go4 when all 8 byte moves are+    -- exhausted.+    go8 :: Reg -> Reg -> Integer -> InstrBlock+    go8 dst reg8byte left =+      if possibleWidth >= 8 then+        let curMov = gen8 dst_addr reg8byte+        in  curMov `appOL` go8 dst reg8byte (left - 8)+      else go4 dst left+      where+        possibleWidth = min left sizeBytes         dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))    if fromInteger insns > ncgInlineThresholdMemset config
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -221,7 +221,7 @@         -- are  Operand Reg.          -- SSE2 floating-point division:-        | FDIV          Format Operand Operand   -- divisor, dividend(dst)+        | FDIV          Format Operand Reg   -- divisor, dividend(dst)          -- use CMP for comparisons.  ucomiss and ucomisd instructions         -- compare single/double prec floating point respectively.@@ -292,8 +292,12 @@         -- NOTE: Instructions follow the AT&T syntax         -- Constructors and deconstructors         | VBROADCAST  Format Operand Reg+        | VPBROADCAST Format Format Operand Reg -- scalar format, vector format, source, destination         | VEXTRACT    Format Imm Reg Operand         | INSERTPS    Format Imm Operand Reg+        | VINSERTPS   Format Imm Operand Reg Reg+        | PINSR       Format Format Imm Operand Reg -- scalar format, vector format, offset, scalar src, vector+        | PEXTR       Format Format Imm Reg Operand -- scalar format, vector format, offset, vector src, scalar dst          -- move operations @@ -309,35 +313,73 @@         | MOVDQU      Format Operand Operand         -- | AVX unaligned move of integer vectors         | VMOVDQU     Format Operand Operand+        -- | Alias for VMOVSS/VMOVSD, used to merge two vectors+        | VMOV_MERGE  Format Reg Reg Reg          -- logic operations         | PXOR        Format Operand Reg         | VPXOR       Format Reg Reg Reg+        | PAND        Format Operand Reg+        | PANDN       Format Operand Reg+        | POR         Format Operand Reg          -- Arithmetic         | VADD       Format Operand Reg Reg         | VSUB       Format Operand Reg Reg         | VMUL       Format Operand Reg Reg         | VDIV       Format Operand Reg Reg+        | PADD       Format Operand Reg+        | PSUB       Format Operand Reg+        | PMULL      Format Operand Reg+        | PMULUDQ    Format Operand Reg +        -- SIMD compare+        | PCMPGT     Format Operand Reg+         -- Shuffle         | SHUF       Format Imm Operand Reg         | VSHUF      Format Imm Operand Reg Reg+        | PSHUFB     Format Operand Reg+        | PSHUFLW    Format Imm Operand Reg+        | PSHUFHW    Format Imm Operand Reg         | PSHUFD     Format Imm Operand Reg         | VPSHUFD    Format Imm Operand Reg+        | BLEND      Format Imm Operand Reg+        | VBLEND     Format Imm Operand Reg Reg+        | PBLENDW    Format Imm Operand Reg          -- | Move two 32-bit floats from the high part of an xmm register         -- to the low part of another xmm register.+        --+        -- If the format is a vector format, the destination register is treated as the second source.+        -- If the format is FF32 or FF64, the destination register is not treated as a source.         | MOVHLPS    Format Reg Reg+        | VMOVHLPS   Format Reg Reg Reg+        | MOVLHPS    Format Reg Reg+        | VMOVLHPS   Format Reg Reg Reg         | UNPCKL     Format Operand Reg+        | VUNPCKL    Format Operand Reg Reg+        | UNPCKH     Format Operand Reg+        | VUNPCKH    Format Operand Reg Reg         | PUNPCKLQDQ Format Operand Reg+        | PUNPCKLDQ  Format Operand Reg+        | PUNPCKLWD  Format Operand Reg+        | PUNPCKLBW  Format Operand Reg+        | PUNPCKHQDQ Format Operand Reg+        | PUNPCKHDQ  Format Operand Reg+        | PUNPCKHWD  Format Operand Reg+        | PUNPCKHBW  Format Operand Reg+        | PACKUSWB   Format Operand Reg          -- Shift-        | PSLLDQ     Format Operand Reg-        | PSRLDQ     Format Operand Reg+        | PSLL       Format Operand Reg+        | PSLLDQ     Format Imm Reg+        | PSRL       Format Operand Reg+        | PSRLDQ     Format Imm Reg+        | PALIGNR    Format Imm Operand Reg          -- min/max-        | MINMAX  MinOrMax MinMaxType Format Operand Operand+        | MINMAX  MinOrMax MinMaxType Format Operand Reg         | VMINMAX MinOrMax MinMaxType Format Operand Reg Reg  data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2@@ -448,7 +490,7 @@     CVTTSD2SIQ fmt src dst -> mkRU (use_R FF64 src []) [mk fmt dst]     CVTSI2SS   fmt src dst -> mkRU (use_R fmt src []) [mk FF32 dst]     CVTSI2SD   fmt src dst -> mkRU (use_R fmt src []) [mk FF64 dst]-    FDIV fmt     src dst  -> usageRM fmt src dst+    FDIV fmt     src dst  -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]     SQRT fmt src dst      -> mkRU (use_R fmt src []) [mk fmt dst]      FETCHGOT reg        -> mkRU [] [mk addrFmt reg]@@ -480,6 +522,7 @@      -- vector instructions     VBROADCAST fmt src dst   -> mkRU (use_R fmt src []) [mk fmt dst]+    VPBROADCAST sFmt vFmt src dst -> mkRU (use_R sFmt src []) [mk vFmt dst]     VEXTRACT     fmt _off src dst -> usageRW fmt (OpReg src) dst     INSERTPS     fmt (ImmInt off) src dst       -> mkRU ((use_R fmt src []) ++ [mk fmt dst | not doesNotReadDst]) [mk fmt dst]@@ -492,6 +535,12 @@             where pos = ( off `shiftR` 4 ) .&. 0b11     INSERTPS fmt _off src dst       -> mkRU ((use_R fmt src []) ++ [mk fmt dst]) [mk fmt dst]+    VINSERTPS fmt _imm src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    PINSR sFmt vFmt _off src dst+      -> mkRU (use_R sFmt src [mk vFmt dst]) [mk vFmt dst]+    PEXTR sFmt vFmt _off src dst+      -> usageRW' vFmt sFmt (OpReg src) dst      VMOVU        fmt src dst   -> usageRW fmt src dst     MOVU         fmt src dst   -> usageRW fmt src dst@@ -499,6 +548,7 @@     MOVH         fmt src dst   -> usageRM fmt src dst     MOVDQU       fmt src dst   -> usageRW fmt src dst     VMOVDQU      fmt src dst   -> usageRW fmt src dst+    VMOV_MERGE   fmt src2 src1 dst -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]      PXOR fmt (OpReg src) dst       | src == dst@@ -512,31 +562,93 @@       | otherwise       -> mkRU [mk fmt s1, mk fmt s2] [mk fmt dst] +    PAND         fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PANDN        fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    POR          fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+     VADD         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]     VSUB         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]     VMUL         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]     VDIV         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]+    PADD         fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PSUB         fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PMULL        fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PMULUDQ      fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] +    PCMPGT       fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+     SHUF fmt _mask src dst       -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]     VSHUF fmt _mask src1 src2 dst       -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]+    PSHUFB fmt mask dst+      -> mkRU (use_R fmt mask [mk fmt dst]) [mk fmt dst]+    PSHUFLW fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]+    PSHUFHW fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]     PSHUFD fmt _mask src dst       -> mkRU (use_R fmt src []) [mk fmt dst]     VPSHUFD fmt _mask src dst       -> mkRU (use_R fmt src []) [mk fmt dst]+    BLEND fmt _mask src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VBLEND fmt _mask src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    PBLENDW fmt _mask src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] -    PSLLDQ fmt off dst -> mkRU (use_R fmt off []) [mk fmt dst]+    PSLL   fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst]+    PSLLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst]+    PSRL   fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst]+    PSRLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst]+    PALIGNR fmt _off src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]      MOVHLPS    fmt src dst-      -> mkRU [mk fmt src] [mk fmt dst]+      -> case fmt of+           VecFormat {} -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]+           -- MOVHLPS moves the high 64 bits of src to the low 64 bits of dst,+           -- keeping the high 64 bits of dst intact.+           -- If we only care about the lower 64 bits of the result,+           -- dst is only written to, not read.+           FF64 -> mkRU [mk (VecFormat 2 FmtDouble) src] [mk fmt dst]+           FF32 -> mkRU [mk (VecFormat 4 FmtFloat) src] [mk fmt dst]+           _ -> pprPanic "regUsage: invalid format for MOVHLPS" (ppr fmt)+    VMOVHLPS   fmt src2 src1 dst+      -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]+    MOVLHPS    fmt src dst+      -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]+    VMOVLHPS   fmt src2 src1 dst+      -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]     UNPCKL fmt src dst       -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VUNPCKL fmt src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    UNPCKH fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VUNPCKH fmt src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]     PUNPCKLQDQ fmt src dst       -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLWD fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLBW fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHQDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHWD fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHBW fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PACKUSWB fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]      MINMAX _ _ fmt src dst-      -> usageRM fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]     VMINMAX _ _ fmt src1 src2 dst       -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]     _other              -> panic "regUsage: unrecognised instr"@@ -696,7 +808,7 @@     CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst)     CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst)     CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst)-    FDIV fmt src dst     -> FDIV fmt (patchOp src) (patchOp dst)+    FDIV fmt src dst     -> FDIV fmt (patchOp src) (env dst)     SQRT fmt src dst    -> SQRT fmt (patchOp src) (env dst)      CALL (Left _)  _    -> instr@@ -735,10 +847,18 @@      -- vector instructions     VBROADCAST   fmt src dst   -> VBROADCAST fmt (patchOp src) (env dst)+    VPBROADCAST  fmt1 fmt2 src dst+      -> VPBROADCAST fmt1 fmt2 (patchOp src) (env dst)     VEXTRACT     fmt off src dst       -> VEXTRACT fmt off (env src) (patchOp dst)     INSERTPS    fmt off src dst       -> INSERTPS fmt off (patchOp src) (env dst)+    VINSERTPS   fmt off src2 src1 dst+      -> VINSERTPS fmt off (patchOp src2) (env src1) (env dst)+    PINSR       fmt1 fmt2 off src dst+      -> PINSR fmt1 fmt2 off (patchOp src) (env dst)+    PEXTR       fmt1 fmt2 off src dst+      -> PEXTR fmt1 fmt2 off (env src) (patchOp dst)      VMOVU      fmt src dst   -> VMOVU fmt (patchOp src) (patchOp dst)     MOVU       fmt src dst   -> MOVU  fmt (patchOp src) (patchOp dst)@@ -746,38 +866,94 @@     MOVH       fmt src dst   -> MOVH  fmt (patchOp src) (patchOp dst)     MOVDQU     fmt src dst   -> MOVDQU  fmt (patchOp src) (patchOp dst)     VMOVDQU    fmt src dst   -> VMOVDQU fmt (patchOp src) (patchOp dst)+    VMOV_MERGE fmt src2 src1 dst -> VMOV_MERGE fmt (env src2) (env src1) (env dst)      PXOR       fmt src dst   -> PXOR fmt (patchOp src) (env dst)     VPXOR      fmt s1 s2 dst -> VPXOR fmt (env s1) (env s2) (env dst)+    PAND       fmt src dst   -> PAND fmt (patchOp src) (env dst)+    PANDN      fmt src dst   -> PANDN fmt (patchOp src) (env dst)+    POR        fmt src dst   -> POR fmt (patchOp src) (env dst)      VADD       fmt s1 s2 dst -> VADD fmt (patchOp s1) (env s2) (env dst)     VSUB       fmt s1 s2 dst -> VSUB fmt (patchOp s1) (env s2) (env dst)     VMUL       fmt s1 s2 dst -> VMUL fmt (patchOp s1) (env s2) (env dst)     VDIV       fmt s1 s2 dst -> VDIV fmt (patchOp s1) (env s2) (env dst)+    PADD       fmt src dst   -> PADD fmt (patchOp src) (env dst)+    PSUB       fmt src dst   -> PSUB fmt (patchOp src) (env dst)+    PMULL      fmt src dst   -> PMULL fmt (patchOp src) (env dst)+    PMULUDQ    fmt src dst   -> PMULUDQ fmt (patchOp src) (env dst) +    PCMPGT     fmt src dst   -> PCMPGT fmt (patchOp src) (env dst)+     SHUF      fmt off src dst       -> SHUF fmt off (patchOp src) (env dst)     VSHUF      fmt off src1 src2 dst       -> VSHUF fmt off (patchOp src1) (env src2) (env dst)+    PSHUFB       fmt mask dst+      -> PSHUFB fmt (patchOp mask) (env dst)+    PSHUFLW      fmt off src dst+      -> PSHUFLW fmt off (patchOp src) (env dst)+    PSHUFHW      fmt off src dst+      -> PSHUFHW fmt off (patchOp src) (env dst)     PSHUFD       fmt off src dst       -> PSHUFD  fmt off (patchOp src) (env dst)     VPSHUFD      fmt off src dst       -> VPSHUFD fmt off (patchOp src) (env dst)+    BLEND        fmt mask src dst+      -> BLEND   fmt mask (patchOp src) (env dst)+    VBLEND       fmt mask src2 src1 dst+      -> VBLEND  fmt mask (patchOp src2) (env src1) (env dst)+    PBLENDW      fmt mask src dst+      -> PBLENDW fmt mask (patchOp src) (env dst) +    PSLL         fmt off dst+      -> PSLL    fmt (patchOp off) (env dst)     PSLLDQ       fmt off dst-      -> PSLLDQ  fmt (patchOp off) (env dst)+      -> PSLLDQ  fmt off (env dst)+    PSRL         fmt off dst+      -> PSRL    fmt (patchOp off) (env dst)     PSRLDQ       fmt off dst-      -> PSRLDQ  fmt (patchOp off) (env dst)+      -> PSRLDQ  fmt off (env dst)+    PALIGNR      fmt off src dst+      -> PALIGNR fmt off (patchOp src) (env dst)      MOVHLPS    fmt src dst       -> MOVHLPS fmt (env src) (env dst)+    VMOVHLPS   fmt src2 src1 dst+      -> VMOVHLPS fmt (env src2) (env src1) (env dst)+    MOVLHPS    fmt src dst+      -> MOVLHPS fmt (env src) (env dst)+    VMOVLHPS   fmt src2 src1 dst+      -> VMOVLHPS fmt (env src2) (env src1) (env dst)     UNPCKL fmt src dst       -> UNPCKL fmt (patchOp src) (env dst)+    VUNPCKL fmt src2 src1 dst+      -> VUNPCKL fmt (patchOp src2) (env src1) (env dst)+    UNPCKH fmt src dst+      -> UNPCKH fmt (patchOp src) (env dst)+    VUNPCKH fmt src2 src1 dst+      -> VUNPCKH fmt (patchOp src2) (env src1) (env dst)     PUNPCKLQDQ fmt src dst       -> PUNPCKLQDQ fmt (patchOp src) (env dst)+    PUNPCKLDQ fmt src dst+      -> PUNPCKLDQ fmt (patchOp src) (env dst)+    PUNPCKLWD fmt src dst+      -> PUNPCKLWD fmt (patchOp src) (env dst)+    PUNPCKLBW fmt src dst+      -> PUNPCKLBW fmt (patchOp src) (env dst)+    PUNPCKHQDQ fmt src dst+      -> PUNPCKHQDQ fmt (patchOp src) (env dst)+    PUNPCKHDQ fmt src dst+      -> PUNPCKHDQ fmt (patchOp src) (env dst)+    PUNPCKHWD fmt src dst+      -> PUNPCKHWD fmt (patchOp src) (env dst)+    PUNPCKHBW fmt src dst+      -> PUNPCKHBW fmt (patchOp src) (env dst)+    PACKUSWB fmt src dst+      -> PACKUSWB fmt (patchOp src) (env dst)      MINMAX minMax ty fmt src dst-      -> MINMAX minMax ty fmt (patchOp src) (patchOp dst)+      -> MINMAX minMax ty fmt (patchOp src) (env dst)     VMINMAX minMax ty fmt src1 src2 dst       -> VMINMAX minMax ty fmt (patchOp src1) (env src2) (env dst) 
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -461,7 +461,7 @@   -- TODO: this is shady because it only works for certain instructions   VecFormat _ FmtInt8   -> text "b"   VecFormat _ FmtInt16  -> text "w"-  VecFormat _ FmtInt32  -> text "l"+  VecFormat _ FmtInt32  -> text "d"   VecFormat _ FmtInt64  -> text "q"  pprFormat_x87 :: IsLine doc => Format -> doc@@ -915,7 +915,7 @@       -> pprFormatOp (text "mul") format op     FDIV format op1 op2-      -> pprFormatOpOp (text "div") format op1 op2+      -> pprFormatOpReg (text "div") format op1 op2     FMA3 format var perm op1 op2 op3       -> let mnemo = case var of@@ -990,8 +990,22 @@      -> pprFormatOpRegReg (text "vmul") format s1 s2 dst    VDIV format s1 s2 dst      -> pprFormatOpRegReg (text "vdiv") format s1 s2 dst-   VBROADCAST format from to-     -> pprBroadcast (text "vbroadcast") format from to+   PADD format src dst+     -> pprFormatOpReg (text "padd") format src dst+   PSUB format src dst+     -> pprFormatOpReg (text "psub") format src dst+   PMULL format src dst+     -> pprFormatOpReg (text "pmull") format src dst+   PMULUDQ format src dst+     -> pprOpReg (text "pmuludq") format src dst+   PCMPGT format src dst+     -> pprFormatOpReg (text "pcmpgt") format src dst+   VBROADCAST format@(VecFormat _ sFmt) from to+     -> pprBroadcast (text "vbroadcast") (scalarFormatFormat sFmt) format from to+   VBROADCAST format _ _+     -> pprPanic "VBROADCAST: expected vector format" (ppr format)+   VPBROADCAST scalarFormat format from to+     -> pprBroadcast (text "vpbroadcast") scalarFormat format from to    VMOVU format from to      -> pprFormatOpOp (text "vmovu") format from to    MOVU format from to@@ -1012,39 +1026,103 @@         VecFormat 32 FmtInt16 -> text "vmovdqu32" -- NB: not using vmovdqu16/8, as they         VecFormat 64 FmtInt8  -> text "vmovdqu32" -- require the additional AVX512BW extension         _ -> text "vmovdqu"+   VMOV_MERGE format src2 src1 dst+     -> pprRegRegReg instr format src2 src1 dst+     where instr = case format of+             VecFormat _ FmtFloat -> text "vmovss"+             VecFormat _ FmtDouble -> text "vmovsd"+             _ -> pprPanic "invalid format for VMOV_MERGE" (ppr format)     PXOR format src dst      -> pprPXor (text "pxor") format src dst    VPXOR format s1 s2 dst      -> pprXor (text "vpxor") format s1 s2 dst+   PAND format src dst+     -> pprOpReg (text "pand") format src dst+   PANDN format src dst+     -> pprOpReg (text "pandn") format src dst+   POR format src dst+     -> pprOpReg (text "por") format src dst    VEXTRACT format offset from to      -> pprFormatImmRegOp (text "vextract") format offset from to    INSERTPS format offset addr dst      -> pprInsert (text "insertps") format offset addr dst+   VINSERTPS format offset src2 src1 dst+     -> pprImmOpRegReg (text "vinsertps") format offset src2 src1 dst+   PINSR scalarFormat vectorFormat offset src dst+     -> pprPinsr (text "pinsr") scalarFormat vectorFormat offset src dst+   PEXTR scalarFormat vectorFormat offset src dst+     -> pprPextr (text "pextr") scalarFormat vectorFormat offset src dst     SHUF format offset src dst      -> pprShuf (text "shuf" <> pprFormat format) format offset src dst    VSHUF format offset src1 src2 dst      -> pprVShuf (text "vshuf" <> pprFormat format) format offset src1 src2 dst+   PSHUFB format mask dst+     -> pprOpReg (text "pshufb") format mask dst+   PSHUFLW format offset src dst+     -> pprShuf (text "pshuflw") format offset src dst+   PSHUFHW format offset src dst+     -> pprShuf (text "pshufhw") format offset src dst    PSHUFD format offset src dst      -> pprShuf (text "pshufd") format offset src dst    VPSHUFD format offset src dst      -> pprShuf (text "vpshufd") format offset src dst+   BLEND format mask src dst+     -> pprFormatImmOpReg (text "blend") format mask src dst+   VBLEND format mask src2 src1 dst+     -> pprFormatImmOpRegReg (text "vblend") format mask src2 src1 dst+   PBLENDW format mask src dst+     -> pprShuf (text "pblendw") format mask src dst +   PSLL format offset dst+     -> pprFormatOpReg (text "psll") format offset dst    PSLLDQ format offset dst      -> pprDoubleShift (text "pslldq") format offset dst+   PSRL format offset dst+     -> pprFormatOpReg (text "psrl") format offset dst    PSRLDQ format offset dst      -> pprDoubleShift (text "psrldq") format offset dst+   PALIGNR format offset src dst+     -> pprImmOpReg (text "palignr") format offset src dst     MOVHLPS format from to      -> pprOpReg (text "movhlps") format (OpReg from) to+   VMOVHLPS format src2 src1 dst+     -> pprRegRegReg (text "vmovhlps") format src2 src1 dst+   MOVLHPS format from to+     -> pprOpReg (text "movlhps") format (OpReg from) to+   VMOVLHPS format src2 src1 dst+     -> pprRegRegReg (text "vmovlhps") format src2 src1 dst    UNPCKL format src dst      -> pprFormatOpReg (text "unpckl") format src dst+   VUNPCKL format src2 src1 dst+     -> pprFormatOpRegReg (text "vunpckl") format src2 src1 dst+   UNPCKH format src dst+     -> pprFormatOpReg (text "unpckh") format src dst+   VUNPCKH format src2 src1 dst+     -> pprFormatOpRegReg (text "vunpckh") format src2 src1 dst    PUNPCKLQDQ format from to      -> pprOpReg (text "punpcklqdq") format from to+   PUNPCKLDQ format from to+     -> pprOpReg (text "punpckldq") format from to+   PUNPCKLWD format from to+     -> pprOpReg (text "punpcklwd") format from to+   PUNPCKLBW format from to+     -> pprOpReg (text "punpcklbw") format from to+   PUNPCKHQDQ format from to+     -> pprOpReg (text "punpckhqdq") format from to+   PUNPCKHDQ format from to+     -> pprOpReg (text "punpckhdq") format from to+   PUNPCKHWD format from to+     -> pprOpReg (text "punpckhwd") format from to+   PUNPCKHBW format from to+     -> pprOpReg (text "punpckhbw") format from to+   PACKUSWB format from to+     -> pprOpReg (text "packuswb") format from to     MINMAX minMax ty fmt src dst-     -> pprMinMax False minMax ty fmt [src, dst]+     -> pprMinMax False minMax ty fmt [src, OpReg dst]    VMINMAX minMax ty fmt src1 src2 dst      -> pprMinMax True minMax ty fmt [src1, OpReg src2, OpReg dst] @@ -1201,6 +1279,17 @@            pprReg platform (archWordFormat (target32Bit platform)) reg2        ] +   pprRegRegReg :: Line doc -> Format -> Reg -> Reg -> Reg -> doc+   pprRegRegReg name format reg1 reg2 reg3+     = line $ hcat [+           pprMnemonic_ name,+           pprReg platform format reg1,+           comma,+           pprReg platform format reg2,+           comma,+           pprReg platform format reg3+       ]+    pprOpReg :: Line doc -> Format -> Operand -> Reg -> doc    pprOpReg name format op reg      = line $ hcat [@@ -1299,16 +1388,14 @@    -- Custom pretty printers    -- These instructions currently don't follow a uniform suffix pattern    -- in their names, so we have custom pretty printers for them.-   pprBroadcast :: Line doc -> Format -> Operand -> Reg -> doc-   pprBroadcast name fmt@(VecFormat _ sFmt) op dst+   pprBroadcast :: Line doc -> Format -> Format -> Operand -> Reg -> doc+   pprBroadcast name scalarFormat vectorFormat op dst      = line $ hcat [-           pprBroadcastMnemonic name fmt,-           pprOperand platform (scalarFormatFormat sFmt) op,+           pprBroadcastMnemonic name vectorFormat,+           pprOperand platform scalarFormat op,            comma,-           pprReg platform fmt dst+           pprReg platform vectorFormat dst        ]-   pprBroadcast _ fmt _ _ =-     pprPanic "pprBroadcast: expected vector format" (ppr fmt)     pprXor :: Line doc -> Format -> Reg -> Reg -> Reg -> doc    pprXor name format reg1 reg2 reg3@@ -1360,6 +1447,28 @@            pprReg platform format dst        ] +   pprPinsr :: Line doc -> Format -> Format -> Imm -> Operand -> Reg -> doc+   pprPinsr name scalarFormat vectorFormat imm src dst+     = line $ hcat [+           pprMnemonic name vectorFormat,+           pprDollImm imm,+           comma,+           pprOperand platform scalarFormat src,+           comma,+           pprReg platform vectorFormat dst+       ]++   pprPextr :: Line doc -> Format -> Format -> Imm -> Reg -> Operand -> doc+   pprPextr name scalarFormat vectorFormat imm src dst+     = line $ hcat [+           pprMnemonic name vectorFormat,+           pprDollImm imm,+           comma,+           pprReg platform vectorFormat src,+           comma,+           pprOperand platform scalarFormat dst+       ]+    pprShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> doc    pprShuf name format imm1 op2 reg3      = line $ hcat [@@ -1384,13 +1493,61 @@            pprReg platform format reg4        ] -   pprDoubleShift :: Line doc -> Format -> Operand -> Reg -> doc+   pprDoubleShift :: Line doc -> Format -> Imm -> Reg -> doc    pprDoubleShift name format off reg      = line $ hcat [            pprGenMnemonic name format,-           pprOperand platform format off,+           pprDollImm off,            comma,            pprReg platform format reg+       ]++   pprImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprImmOpReg name format imm1 op2 reg3+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++   pprFormatImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprFormatImmOpReg name format imm1 op2 reg3+     = line $ hcat [+           pprMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++   pprImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc+   pprImmOpRegReg name format imm1 op2 reg3 reg4+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3,+           comma,+           pprReg platform format reg4+       ]++   pprFormatImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc+   pprFormatImmOpRegReg name format imm1 op2 reg3 reg4+     = line $ hcat [+           pprMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3,+           comma,+           pprReg platform format reg4        ]     pprMinMax :: Bool -> MinOrMax -> MinMaxType -> Format -> [Operand] -> doc
compiler/GHC/CmmToAsm/X86/RegInfo.hs view
@@ -68,4 +68,3 @@ --             ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb" --             ,"#d2d2d2","#d9d9d9","#e0e0e0"] -
compiler/GHC/CmmToC.hs view
@@ -873,26 +873,10 @@                                 (text "MO_V_Mul")                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"                                       ++ "unsupported by the unregisterised backend")-        MO_VS_Quot {}     -> pprTrace "offending mop:"-                                (text "MO_VS_Quot")-                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"-                                      ++ "unsupported by the unregisterised backend")-        MO_VS_Rem {}      -> pprTrace "offending mop:"-                                (text "MO_VS_Rem")-                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"-                                      ++ "unsupported by the unregisterised backend")         MO_VS_Neg {}      -> pprTrace "offending mop:"                                 (text "MO_VS_Neg")                                 (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"                                       ++ "unsupported by the unregisterised backend")-        MO_VU_Quot {}     -> pprTrace "offending mop:"-                                (text "MO_VU_Quot")-                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"-                                      ++ "unsupported by the unregisterised backend")-        MO_VU_Rem {}      -> pprTrace "offending mop:"-                                (text "MO_VU_Rem")-                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"-                                      ++ "unsupported by the unregisterised backend")         MO_V_Broadcast {} -> pprTrace "offending mop:"                                  (text "MO_V_Broadcast")                                  (panic $ "PprC.pprMachOp_for_C: MO_V_Broadcast"@@ -1063,6 +1047,14 @@         MO_AddIntC    {} -> unsupported         MO_SubIntC    {} -> unsupported         MO_U_Mul2     {} -> unsupported+        MO_VS_Quot    {} -> unsupported+        MO_VS_Rem     {} -> unsupported+        MO_VU_Quot    {} -> unsupported+        MO_VU_Rem     {} -> unsupported+        MO_I64X2_Min     -> unsupported+        MO_I64X2_Max     -> unsupported+        MO_W64X2_Min     -> unsupported+        MO_W64X2_Max     -> unsupported         MO_Touch         -> unsupported         -- we could support prefetch via "__builtin_prefetch"         -- Not adding it for now
compiler/GHC/CmmToLlvm.hs view
@@ -222,7 +222,12 @@           case platformArch platform of             ArchX86_64 | llvmCgAvxEnabled cfg -> [mkStackAlignmentMeta 32]             _                                 -> []-  module_flags_metas <- mkModuleFlagsMeta stack_alignment_metas+  let codel_model_metas =+          case platformArch platform of+            -- FIXME: We should not rely on LLVM+            ArchLoongArch64 -> [mkCodeModelMeta CMMedium]+            _                                 -> []+  module_flags_metas <- mkModuleFlagsMeta (stack_alignment_metas ++ codel_model_metas)   let metas = tbaa_metas ++ module_flags_metas   cfg <- getConfig   renderLlvm (ppLlvmMetas cfg metas)@@ -245,6 +250,15 @@ mkStackAlignmentMeta alignment =     ModuleFlag MFBError "override-stack-alignment" (MetaLit $ LMIntLit alignment i32) +-- LLVM's @LLVM::CodeModel::Model@ enumeration+data CodeModel = CMMedium++-- Pass -mcmodel=medium option to LLVM on LoongArch64+mkCodeModelMeta :: CodeModel -> ModuleFlag+mkCodeModelMeta codemodel =+    ModuleFlag MFBError "Code Model" (MetaLit $ LMIntLit n i32)+  where+    n = case codemodel of CMMedium -> 3 -- as of LLVM 8  -- ----------------------------------------------------------------------------- -- | Marks variables as used where necessary
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- | Handle conversion of CmmProc to LLVM code. module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where@@ -27,6 +26,7 @@ import GHC.Cmm.Dataflow.Label  import GHC.Data.FastString+import GHC.Data.Maybe (expectJust) import GHC.Data.OrdList  import GHC.Types.ForeignCall@@ -43,7 +43,10 @@ import Control.Monad  import qualified Data.Semigroup as Semigroup+import Data.Foldable ( toList ) import Data.List ( nub )+import qualified Data.List as List+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import Data.Maybe ( catMaybes )  type Atomic = Maybe MemoryOrdering@@ -55,9 +58,8 @@ -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]-genLlvmProc (CmmProc infos lbl live graph) = do-    let blocks = toBlockListEntryFirstFalseFallthrough graph-+genLlvmProc (CmmProc infos lbl live graph)+  | Just blocks <- nonEmpty $ toBlockListEntryFirstFalseFallthrough graph = do     (lmblocks, lmdata) <- basicBlocksCodeGen live blocks     let info = mapLookup (g_entry graph) infos         proc = CmmProc info lbl live (ListGraph lmblocks)@@ -77,9 +79,8 @@ -- | Generate code for a list of blocks that make up a complete -- procedure. The first block in the list is expected to be the entry -- point.-basicBlocksCodeGen :: LiveGlobalRegUses -> [CmmBlock]+basicBlocksCodeGen :: LiveGlobalRegUses -> NonEmpty CmmBlock                       -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])-basicBlocksCodeGen _    []                     = panic "no entry block!" basicBlocksCodeGen live cmmBlocks   = do -- Emit the prologue        -- N.B. this must be its own block to ensure that the entry block of the@@ -97,7 +98,7 @@        let ubblock = BasicBlock ubid' [Unreachable]         -- Generate code-       (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) cmmBlocks+       (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) $ toList cmmBlocks         -- Compose        return (entryBlock : ubblock : blocks, prologueTops ++ concat topss)@@ -229,23 +230,22 @@     statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []   | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) --- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg--- and return types-genCall t@(PrimTarget (MO_PopCnt w)) dsts args =-    genCallSimpleCast w t dsts args--genCall t@(PrimTarget (MO_Pdep w)) dsts args =-    genCallSimpleCast2 w t dsts args-genCall t@(PrimTarget (MO_Pext w)) dsts args =-    genCallSimpleCast2 w t dsts args-genCall t@(PrimTarget (MO_Clz w)) dsts args =-    genCallSimpleCast w t dsts args-genCall t@(PrimTarget (MO_Ctz w)) dsts args =-    genCallSimpleCast w t dsts args-genCall t@(PrimTarget (MO_BSwap w)) dsts args =-    genCallSimpleCast w t dsts args-genCall t@(PrimTarget (MO_BRev w)) dsts args =-    genCallSimpleCast w t dsts args+-- Handle Clz, Ctz, BRev, BSwap, Pdep, Pext, and PopCnt that need to only+-- convert arg and return types+genCall (PrimTarget op@(MO_Clz w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_Ctz w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_BRev w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_BSwap w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_Pdep w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_Pext w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_PopCnt w)) [dst] args =+    genCallSimpleCast w op dst args  genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do     addrVar <- exprToVarW addr@@ -443,6 +443,34 @@ genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =     genCallWithOverflow t w [dstV, dstO] [lhs, rhs] +genCall (PrimTarget (MO_VS_Quot l w)) [dst] [lhs, rhs] = runStmtsDecls $ do+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_SDiv lhsVar rhsVar)+    (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst)+    statement $ Store result dstReg Nothing []++genCall (PrimTarget (MO_VS_Rem l w)) [dst] [lhs, rhs] = runStmtsDecls $ do+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_SRem lhsVar rhsVar)+    (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst)+    statement $ Store result dstReg Nothing []++genCall (PrimTarget (MO_VU_Quot l w)) [dst] [lhs, rhs] = runStmtsDecls $ do+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_UDiv lhsVar rhsVar)+    (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst)+    statement $ Store result dstReg Nothing []++genCall (PrimTarget (MO_VU_Rem l w)) [dst] [lhs, rhs] = runStmtsDecls $ do+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_URem lhsVar rhsVar)+    (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst)+    statement $ Store result dstReg Nothing []+ -- Handle all other foreign calls and prim ops. genCall target res args = do   platform <- getPlatform@@ -611,64 +639,29 @@ -- since GHC only really has i32 and i64 types and things like Word8 are backed -- by an i32 and just present a logical i8 range. So we must handle conversions -- from i32 to i8 explicitly as LLVM is strict about types.-genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]-              -> LlvmM StmtData-genCallSimpleCast w t@(PrimTarget op) [dst] args = do-    let width = widthToLlvmInt w-        dstTy = cmmToLlvmType $ localRegType dst--    fname                       <- cmmPrimOpFunctions op-    (fptr, _, top3)             <- getInstrinct fname width [width]--    (dstV, _dst_ty)             <- getCmmReg (CmmLocal dst)+genCallSimpleCast :: Width -> CallishMachOp -> CmmFormal -> [CmmActual]+                  -> LlvmM StmtData+genCallSimpleCast specW op dst args = do+    let width   = widthToLlvmInt specW+        argsW   = const width <$> args+        dstType = cmmToLlvmType $ localRegType dst+        signage = cmmPrimOpRetValSignage op -    let (_, arg_hints) = foreignTargetHints t-    let args_hints = zip args arg_hints-    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])-    (argsV', stmts4)            <- castVars Signed $ zip argsV [width]-    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []-    (retVs', stmts5)            <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]-    let retV'                    = singletonPanic "genCallSimpleCast" retVs'-    let s2                       = Store retV' dstV Nothing []+    fname                 <- cmmPrimOpFunctions op+    (fptr, _, top3)       <- getInstrinct fname width argsW+    (dstV, _dst_ty)       <- getCmmReg (CmmLocal dst)+    let (_, arg_hints)     = foreignTargetHints $ PrimTarget op+    let args_hints         = zip args arg_hints+    (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, [])+    (argsV', stmts4)      <- castVars signage $ zip argsV argsW+    (retV, s1)            <- doExpr width $ Call StdCall fptr argsV' []+    (retV', stmts5)       <- castVar signage retV dstType+    let s2                 = Store retV' dstV Nothing []      let stmts = stmts2 `appOL` stmts4 `snocOL`-                s1 `appOL` stmts5 `snocOL` s2+                s1 `snocOL` stmts5 `snocOL` s2     return (stmts, top2 ++ top3)-genCallSimpleCast _ _ dsts _ =-    panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") --- Handle simple function call that only need simple type casting, of the form:---   truncate arg >>= \a -> call(a) >>= zext------ since GHC only really has i32 and i64 types and things like Word8 are backed--- by an i32 and just present a logical i8 range. So we must handle conversions--- from i32 to i8 explicitly as LLVM is strict about types.-genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]-              -> LlvmM StmtData-genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do-    let width = widthToLlvmInt w-        dstTy = cmmToLlvmType $ localRegType dst--    fname                       <- cmmPrimOpFunctions op-    (fptr, _, top3)             <- getInstrinct fname width (const width <$> args)--    (dstV, _dst_ty)             <- getCmmReg (CmmLocal dst)--    let (_, arg_hints) = foreignTargetHints t-    let args_hints = zip args arg_hints-    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])-    (argsV', stmts4)            <- castVars Signed $ zip argsV (const width <$> argsV)-    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []-    (retVs', stmts5)             <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]-    let retV'                    = singletonPanic "genCallSimpleCast2" retVs'-    let s2                       = Store retV' dstV Nothing []--    let stmts = stmts2 `appOL` stmts4 `snocOL`-                s1 `appOL` stmts5 `snocOL` s2-    return (stmts, top2 ++ top3)-genCallSimpleCast2 _ _ dsts _ =-    panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts")- -- | Create a function pointer from a target. getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget            -> WriterT LlvmAccum LlvmM LlvmVar@@ -782,11 +775,47 @@             Signed      -> LM_Sext             Unsigned    -> LM_Zext - cmmPrimOpRetValSignage :: CallishMachOp -> Signage cmmPrimOpRetValSignage mop = case mop of-    MO_Pdep _   -> Unsigned-    MO_Pext _   -> Unsigned+    -- Some bit-wise operations /must/ always treat the input and output values+    -- as 'Unsigned' in order to return the expected result values when pre/post-+    -- operation bit-width truncation and/or extension occur. For example,+    -- consider the Bit-Reverse operation:+    --+    -- If the result of a Bit-Reverse is treated as signed,+    -- an positive input can result in an negative output, i.e.:+    --+    --   identity(0x03) = 0x03 = 00000011+    --   breverse(0x03) = 0xC0 = 11000000+    --+    -- Now if an extension is performed after the operation to+    -- promote a smaller bit-width value into a larger bit-width+    -- type, it is expected that the /bit-wise/ operations will+    -- not be treated /numerically/ as signed.+    --+    -- To illustrate the difference, consider how a signed extension+    -- for the type i16 to i32 differs for out values above:+    --   ext_zeroed(i32, breverse(0x03)) = 0x00C0 = 0000000011000000+    --   ext_signed(i32, breverse(0x03)) = 0xFFC0 = 1111111111000000+    --+    -- Here we can see that the former output is the expected result+    -- of a bit-wise operation which needs to be promoted to a larger+    -- bit-width type. The latter output is not desirable when we must+    -- constraining a value into a range of i16 within an i32 type.+    --+    -- Hence we always treat the "signage" as unsigned for Bit-Reverse!+    --+    -- The same reasoning applied to Bit-Reverse above applies to the other+    -- bit-wise operations; do not sign extend a possibly negated number!+    MO_BRev   _ -> Unsigned+    MO_BSwap  _ -> Unsigned+    MO_Clz    _ -> Unsigned+    MO_Ctz    _ -> Unsigned+    MO_Pdep   _ -> Unsigned+    MO_Pext   _ -> Unsigned+    MO_PopCnt _ -> Unsigned++    -- All other cases, default to preserving the numeric sign when extending.     _           -> Signed  -- | Decide what C function to use to implement a CallishMachOp@@ -1002,6 +1031,15 @@     -- appropriate case of genCall.     MO_U_Mul2 {}     -> unsupported +    MO_VS_Quot {} -> unsupported+    MO_VS_Rem {}  -> unsupported+    MO_VU_Quot {} -> unsupported+    MO_VU_Rem {}  -> unsupported+    MO_I64X2_Min  -> unsupported+    MO_I64X2_Max  -> unsupported+    MO_W64X2_Min  -> unsupported+    MO_W64X2_Max  -> unsupported+     MO_ReleaseFence  -> unsupported     MO_AcquireFence  -> unsupported     MO_SeqCstFence   -> unsupported@@ -1514,13 +1552,9 @@     MO_V_Sub      _ _ -> panicOp     MO_V_Mul      _ _ -> panicOp -    MO_VS_Quot    _ _ -> panicOp-    MO_VS_Rem     _ _ -> panicOp     MO_VS_Min     _ _ -> panicOp     MO_VS_Max     _ _ -> panicOp -    MO_VU_Quot    _ _ -> panicOp-    MO_VU_Rem     _ _ -> panicOp     MO_VU_Min     _ _ -> panicOp     MO_VU_Max     _ _ -> panicOp @@ -1698,12 +1732,6 @@     MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub     MO_V_Mul l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul -    MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv-    MO_VS_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem--    MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv-    MO_VU_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem-     MO_VF_Add  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd     MO_VF_Sub  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub     MO_VF_Mul  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul@@ -2117,10 +2145,17 @@         --                 ]     in return (mkIntLit width i, nilOL, []) -genLit _ (CmmFloat r w)-  = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),+genLit _ (CmmFloat r W32)+  = return (LMLitVar $ LMFloatLit (widenFp (fromRational r :: Float)) (widthToLlvmFloat W32),               nilOL, []) +genLit _ (CmmFloat r W64)+  = return (LMLitVar $ LMFloatLit (fromRational r :: Double) (widthToLlvmFloat W64),+              nilOL, [])++genLit _ (CmmFloat _r _w)+  = panic "genLit (CmmLit:CmmFloat), unsupported float lit"+ genLit opt (CmmVec ls)   = do llvmLits <- mapM toLlvmLit ls        return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])@@ -2197,7 +2232,7 @@ -- question is never written. Therefore we skip it where we can to -- save a few lines in the output and hopefully speed compilation up a -- bit.-funPrologue :: LiveGlobalRegUses -> [CmmBlock] -> LlvmM StmtData+funPrologue :: LiveGlobalRegUses -> NonEmpty CmmBlock -> LlvmM StmtData funPrologue live cmmBlocks = do   platform <- getPlatform @@ -2243,7 +2278,7 @@    return (concatOL stmtss `snocOL` jumpToEntry, [])   where-    entryBlk : _ = cmmBlocks+    entryBlk :| _ = cmmBlocks     jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk)  -- | Function epilogue. Load STG variables to use as argument for call.@@ -2356,9 +2391,8 @@  -- | Returns TBAA meta data by unique getTBAAMeta :: Unique -> LlvmM [MetaAnnot]-getTBAAMeta u = do-    mi <- getUniqMeta u-    return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]+getTBAAMeta u =+    List.singleton . MetaAnnot tbaa . MetaNode . expectJust <$> getUniqMeta u  -- | Returns TBAA meta data for given register getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
compiler/GHC/CmmToLlvm/Data.hs view
@@ -10,6 +10,7 @@ import GHC.Prelude  import GHC.Llvm+import GHC.Llvm.Types (widenFp) import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Config @@ -193,8 +194,14 @@ genStaticLit (CmmInt i w)     = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) -genStaticLit (CmmFloat r w)-    = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))+genStaticLit (CmmFloat r W32)+    = return $ LMStaticLit (LMFloatLit (widenFp (fromRational r :: Float)) (widthToLlvmFloat W32))++genStaticLit (CmmFloat r W64)+    = return $ LMStaticLit (LMFloatLit (fromRational r :: Double) (widthToLlvmFloat W64))++genStaticLit (CmmFloat _r _w)+    = panic "genStaticLit (CmmLit:CmmFloat), unsupported float lit"  genStaticLit (CmmVec ls)     = do sls <- mapM toLlvmLit ls
compiler/GHC/Core/LateCC/OverloadedCalls.hs view
@@ -25,7 +25,6 @@ import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Types.Var-import GHC.Utils.Outputable  type OverloadedCallsCCState = Strict.Maybe SrcSpan @@ -103,7 +102,7 @@           -- check if any of the arguments v1 ... vN are dictionaries.           let             (f, xs) = collectArgs app-            resultTy = applyTypeToArgs empty (exprType f) xs+            resultTy = applyTypeToArgs (exprType f) xs            -- Recursively process the arguments first for no particular reason           args <- mapM processExpr xs
compiler/GHC/Core/LateCC/TopLevelBinds.hs view
compiler/GHC/Core/Opt/CSE.hs view
@@ -9,7 +9,7 @@ import GHC.Prelude  import GHC.Core.Subst-import GHC.Types.Var.Env ( mkInScopeSet )+import GHC.Types.Var.Env ( mkInScopeSet, mkInScopeSetList ) import GHC.Types.Id import GHC.Core.Utils   ( mkAltExpr                         , exprIsTickedString@@ -379,14 +379,21 @@ -}  cseProgram :: CoreProgram -> CoreProgram-cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)+cseProgram binds+  = snd (mapAccumL (cseBind TopLevel) init_env binds)+  where+    init_env  = emptyCSEnv $+                mkInScopeSetList (bindersOfBinds binds)+                -- Put all top-level binders into scope; it is possible to have+                -- forward references.  See Note [Glomming] in GHC.Core.Opt.OccurAnal+                -- Missing this caused #25468  cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) cseBind toplevel env (NonRec b e)   = (env2, NonRec b2 e2)   where     -- See Note [Separate envs for let rhs and body]-    (env1, b1)       = addBinder env b+    (env1, b1)       = addNonRecBinder toplevel env b     (env2, (b2, e2)) = cse_bind toplevel env env1 (b,e) b1  cseBind toplevel env (Rec [(in_id, rhs)])@@ -404,7 +411,7 @@   = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])    where-    (env1, Identity out_id) = addRecBinders env (Identity in_id)+    (env1, Identity out_id) = addRecBinders toplevel env (Identity in_id)     rhs'  = cseExpr env1 rhs     rhs'' = stripTicksE tickishFloatable rhs'     ticks = stripTicksT tickishFloatable rhs'@@ -414,7 +421,7 @@ cseBind toplevel env (Rec pairs)   = (env2, Rec pairs')   where-    (env1, bndrs1) = addRecBinders env (map fst pairs)+    (env1, bndrs1) = addRecBinders toplevel env (map fst pairs)     (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)      do_one env (pr, b1) = cse_bind toplevel env env pr b1@@ -631,7 +638,10 @@   doing this if there are no RULES; and other things being   equal it delays optimisation to delay inlining (#17409) +* There can be a subtle order-dependency, as described in #25526;+  it may matter whether we end up with f=g or g=f. + ---- Historical note ---  This patch is simpler and more direct than an earlier@@ -692,7 +702,8 @@ -- as a convenient entry point for users of the GHC API. cseOneExpr :: InExpr -> OutExpr cseOneExpr e = cseExpr env e-  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }+  where+    env = emptyCSEnv (mkInScopeSet (exprFreeVars e))  cseExpr :: CSEnv -> InExpr -> OutExpr cseExpr env (Type t)              = Type (substTyUnchecked (csEnvSubst env) t)@@ -858,9 +869,11 @@             -- See Note [CSE for recursive bindings]        } -emptyCSEnv :: CSEnv-emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap-                , cs_subst = emptySubst }+emptyCSEnv :: InScopeSet -> CSEnv+emptyCSEnv in_scope+    = CS { cs_map     = emptyCoreMap+         , cs_rec_map = emptyCoreMap+         , cs_subst   = mkEmptySubst in_scope }  lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr lookupCSEnv (CS { cs_map = csmap }) expr@@ -905,8 +918,19 @@                 where                   (sub', vs') = substBndrs (cs_subst cse) vs -addRecBinders :: Traversable f => CSEnv -> f Id -> (CSEnv, f Id)-addRecBinders = \ cse vs ->-    let (sub', vs') = substRecBndrs (cs_subst cse) vs-    in (cse { cs_subst = sub' }, vs')+addNonRecBinder :: TopLevelFlag -> CSEnv -> Var -> (CSEnv, Var)+-- Don't clone at top level+addNonRecBinder top_lvl cse v+  | isTopLevel top_lvl = (cse,                      v)+  | otherwise          = (cse { cs_subst = sub' }, v')+  where+    (sub', v') = substBndr (cs_subst cse) v++addRecBinders :: Traversable f => TopLevelFlag -> CSEnv -> f Id -> (CSEnv, f Id)+-- Don't clone at top level+addRecBinders top_lvl cse vs+  | isTopLevel top_lvl  = (cse,                     vs)+  | otherwise           = (cse { cs_subst = sub' }, vs')+  where+    (sub', vs') = substRecBndrs (cs_subst cse) vs {-# INLINE addRecBinders #-}
compiler/GHC/Core/Opt/CallArity.hs view
@@ -23,6 +23,7 @@ import GHC.Utils.Misc  import Control.Arrow ( first, second )+import Data.List.NonEmpty ( NonEmpty (..) )   {-@@ -696,7 +697,7 @@  -- See Note [Trimming arity] trimArity :: Id -> Arity -> Arity-trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]+trimArity v a = minimum (a :| max_arity_by_type : max_arity_by_strsig : [])   where     max_arity_by_type = typeArity (idType v)     max_arity_by_strsig
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -213,7 +213,7 @@   -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType'  cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $-                  cprAnal' env e+                cprAnal' env e  cprAnal' _ (Lit lit)     = (topCprType, Lit lit) cprAnal' _ (Type ty)     = (topCprType, Type ty)      -- Doesn't happen, in fact@@ -289,7 +289,7 @@             -> extendSigEnvAllSame env ids sig           ForeachField field_cprs             | let sigs = zipWith (mkCprSig . idArity) ids field_cprs-            -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs)+            -> extendSigEnvList env (zipEqual ids sigs)       | otherwise       = extendSigEnvAllSame env ids topCprSig     (rhs_ty, rhs') = cprAnal env_alt rhs@@ -304,9 +304,16 @@  -- See Note [Nested CPR] exprTerminates :: CoreExpr -> TermFlag+-- ^ A /very/ simple termination analysis. exprTerminates e-  | exprIsHNF e = Terminates -- A /very/ simple termination analysis.-  | otherwise   = MightDiverge+  | exprIsHNF e            = Terminates+  | exprOkForSpeculation e = Terminates+  | otherwise              = MightDiverge+  -- Annoyingly, we have to check both for HNF and ok-for-spec.+  --   * `I# (x# *# 2#)` is ok-for-spec, but not in HNF. Still worth CPR'ing!+  --   * `lvl` is an HNF if its unfolding is evaluated+  --     (perhaps `lvl = I# 0#` at top-level). But, tiresomely, it is never+  --     ok-for-spec due to Note [exprOkForSpeculation and evaluated variables].  cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr) -- Main function that takes care of /nested/ CPR. See Note [Nested CPR]@@ -347,7 +354,7 @@   | isLocalId id   = assertPpr (isDataStructure id) (ppr id) topCprType   -- See Note [CPR for DataCon wrappers]-  | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id)+  | Just rhs <- dataConWrapUnfolding_maybe id   = fst $ cprAnalApp env rhs args   -- DataCon worker   | Just con <- isDataConWorkId_maybe id@@ -369,14 +376,16 @@ -- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker, -- given a saturated number of 'CprType's for its field expressions. -- Implements the Nested part of Note [Nested CPR].-cprTransformDataConWork :: AnalEnv -> DataCon -> [(CprType, CoreArg)] -> CprType+cprTransformDataConWork :: AnalEnv -> DataCon+                        -> [(CprType, CoreArg)]   -- Info about /value/ arguments+                        -> CprType cprTransformDataConWork env con args   | null (dataConExTyCoVars con)  -- No existentials   , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE]   , args `lengthIs` wkr_arity   , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]-  -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True-  = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))+  = -- pprTraceWith "cprTransformDataConWork" (\r -> ppr con <+> ppr wkr_arity <+> ppr args <+> ppr r) $+    CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))   | otherwise   = topCprType   where@@ -532,7 +541,8 @@   | isDataStructure id -- Data structure => no code => no need to analyse rhs   = (id,  rhs,  env)   | otherwise-  = (id `setIdCprSig` sig',       rhs', env')+  = -- pprTrace "cprAnalBind" (ppr id <+> ppr sig <+> ppr sig')+    (id `setIdCprSig` sig',       rhs', env')   where     (rhs_ty, rhs')  = cprAnal env rhs     -- possibly trim thunk CPR info
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -23,7 +23,6 @@ import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type-import GHC.Core.Predicate( isEqualityClass, isCTupleClass ) import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs     ( coVarsOfCos )@@ -555,7 +554,9 @@     WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs'])     where       want_precise_field_dmds (DataAlt dc)-        | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc+        | let tc = dataConTyCon dc+        , assertPpr (not (isNewTyCon tc)) (ppr dc) True  -- DataAlt is never newtype+        , Nothing <- tyConSingleDataCon_maybe $ dataConTyCon dc         = False    -- Not a product type, even though this is the                    -- only remaining possible data constructor         | DefinitelyRecursive <- ae_rec_dc env dc@@ -835,6 +836,10 @@ from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. +You might think that we should check for side-effects rather than just for+precise exceptions. Right you are! See Note [Side-effects and strictness]+for why we unfortunately do not.+ Note [Demand analysis for recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ T11545 features a single-product, recursive data type@@ -1015,7 +1020,7 @@   = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $     dmdTransformDataConSig (dataConRepStrictness con) sd   -- See Note [DmdAnal for DataCon wrappers]-  | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var)+  | Just rhs <- dataConWrapUnfolding_maybe var   , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs   = dmd_ty   -- Dictionary component selectors@@ -1162,8 +1167,8 @@     go depth ty sd       | depth <= max_depth       , Just (tc, tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ty-      , Just dc <- tyConSingleAlgDataCon_maybe tc-      , null (dataConExTyCoVars dc) -- Can't unbox results with existentials+      , Just [dc] <- canUnboxTyCon tc   -- tc is not a newtype+      , null (dataConExTyCoVars dc)     -- Can't unbox results with existentials       , dataConRepArity dc <= dmd_unbox_width (ae_opts env)       , Just (_, ds) <- viewProd (dataConRepArity dc) sd       , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args@@ -2026,7 +2031,7 @@   -- The normal case   | otherwise   = -- pprTrace "finaliseArgBoxities" (-    --   vcat [text "function:" <+> ppr fn+    -- vcat [text "function:" <+> ppr fn     --        , text "max" <+> ppr max_wkr_args     --        , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))     --        , text "dmds after: " <+>  ppr arg_dmds' ]) $@@ -2167,12 +2172,6 @@          -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal        -> DontUnbox -       | doNotUnbox ty-       -> DontUnbox  -- See Note [Do not unbox class dictionaries]-                     -- NB: 'ty' has not been normalised, so this will (rightly)-                     --     catch newtype dictionaries too.-                     -- NB: even for bottoming functions, don't unbox dictionaries-        | DefinitelyRecursive <- ae_rec_dc env dc          -- See Note [Which types are unboxed?]          -- and Note [Demand analysis for recursive data constructors]@@ -2182,76 +2181,6 @@        -> DoUnbox (zip3 (dubiousDataConInstArgTys dc tc_args)                         (dataConRepStrictness dc)                         dmds)---doNotUnbox :: Type -> Bool--- Do not unbox class dictionaries, except equality classes and tuples--- Note [Do not unbox class dictionaries]-doNotUnbox arg_ty-  = case tyConAppTyCon_maybe arg_ty of-      Just tc | Just cls <- tyConClass_maybe tc-              -> not (isEqualityClass cls || isCTupleClass cls)-       -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries]--      _ -> False--{- Note [Do not unbox class dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We never unbox class dictionaries in worker/wrapper.--1. INLINABLE functions-   If we have-      f :: Ord a => [a] -> Int -> a-      {-# INLINABLE f #-}-   and we worker/wrapper f, we'll get a worker with an INLINABLE pragma-   (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),-   which can still be specialised by the type-class specialiser, something like-      fw :: Ord a => [a] -> Int# -> a--   BUT if f is strict in the Ord dictionary, we might unpack it, to get-      fw :: (a->a->Bool) -> [a] -> Int# -> a-   and the type-class specialiser can't specialise that. An example is #6056.--   Historical note: #14955 describes how I got this fix wrong the first time.-   I got aware of the issue in T5075 by the change in boxity of loop between-   demand analysis runs.--2. -fspecialise-aggressively.  As #21286 shows, the same phenomenon can occur-   occur without INLINABLE, when we use -fexpose-all-unfoldings and-   -fspecialise-aggressively to do vigorous cross-module specialisation.--3. #18421 found that unboxing a dictionary can also make the worker less likely-   to inline; the inlining heuristics seem to prefer to inline a function-   applied to a dictionary over a function applied to a bunch of functions.--TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing-a raft of higher-order functions isn't a huge win anyway -- you really want to-specialise the function.--Wrinkle (DNB1): we /do/ want to unbox tuple dictionaries (#23398)-     f :: (% Eq a, Show a %) => blah-  with -fdicts-strict it is great to unbox to-     $wf :: Eq a => Show a => blah-  (where I have written out the currying explicitly).  Now we can specialise-  $wf on the Eq or Show dictionary.  Nothing is lost.--  And something is gained.  It is possible that `f` will look like this:-     f = /\a. \d:(% Eq a, Show a %). ... f @a (% sel1 d, sel2 d %)...-  where there is a recurive call to `f`, or to another function that takes the-  same tuple dictionary, but where the tuple is built from the components of-  `d`.  The Simplier does not fix this.  But if we unpacked the dictionary-  we'd get-     $wf = /\a. \(d1:Eq a) (d2:Show a). let d = (% d1, d2 %)-             in ...f @a (% sel1 d, sel2 d %)-  and all the tuple building and taking apart will disappear.--Wrinkle (DNB2): we /do/ want to unbox equality dictionaries,-  for (~), (~~), and Coercible (#23398).  Their payload is a single unboxed-  coercion.  We never want to specialise on `(t1 ~ t2)`.  All that would do is-  to make a copy of the function's RHS with a particular coercion.  Unlike-  normal class methods, that does not unlock any new optimisation-  opportunities in the specialised RHS.--}  {- ********************************************************************* *                                                                      *
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -173,7 +173,7 @@   = wrapFloats drop_here $     mkTicks ticks $     mkApps (fiExpr platform fun_drop ann_fun)-           (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)+           (zipWithEqual (fiExpr platform) arg_drops ann_args)            -- use zipWithEqual, we should have            -- length ann_args = length arg_fvs = length arg_drops   where@@ -543,7 +543,7 @@   = wrapFloats drop_here1 $     wrapFloats drop_here2 $     Case (fiExpr platform scrut_drops scrut) case_bndr ty-         (zipWithEqual "fiExpr" fi_alt alts_drops_s alts)+         (zipWithEqual fi_alt alts_drops_s alts)          -- use zipWithEqual, we should have length alts_drops_s = length alts   where         -- Float into the scrut and alts-considered-together just like App@@ -640,7 +640,7 @@      fi_bind to_drops pairs       = [ (binder, fiRhs platform to_drop binder rhs)-        | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]+        | ((binder, rhs), to_drop) <- zipEqual pairs to_drops ]  ------------------ fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr@@ -821,7 +821,7 @@             | otherwise = floatIsCase bind || n_used_alts > 1                              -- floatIsCase: see Note [Floating primops] -          new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe+          new_fork_boxes = zipWithEqual insert_maybe                                         fork_boxes used_in_flags            insert :: DropBox -> DropBox
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -22,7 +22,7 @@  import GHC.Core import GHC.Core.Opt.CSE  ( cseProgram )-import GHC.Core.Rules   ( RuleBase, mkRuleBase, ruleCheckProgram, getRules )+import GHC.Core.Rules   ( RuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr     ( pprCoreBindings ) import GHC.Core.Utils   ( dumpIdInfoOfProgram ) import GHC.Core.Lint    ( lintAnnots )@@ -76,7 +76,8 @@ core2core hsc_env guts@(ModGuts { mg_module  = mod                                 , mg_loc     = loc                                 , mg_rdr_env = rdr_env })-  = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars+  = do { hpt_rule_base <- home_pkg_rules+       ; let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars              uniq_tag = 's'         ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod@@ -96,11 +97,11 @@   where     dflags         = hsc_dflags hsc_env     logger         = hsc_logger hsc_env+    unit_env       = hsc_unit_env hsc_env     extra_vars     = interactiveInScope (hsc_IC hsc_env)-    home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod-                                                               , gwib_isBoot = NotBoot })-    hpt_rule_base  = mkRuleBase home_pkg_rules-    name_ppr_ctx   = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env+    home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod)+                      (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot })+    name_ppr_ctx   = mkNamePprCtx ptc unit_env rdr_env     ptc            = initPromotionTickContext dflags     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.     -- This is very convienent for the users of the monad (e.g. plugins do not have to
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -614,7 +614,8 @@   = lvlExpr env e     -- See Note [Case MFEs]  lvlMFE env strict_ctxt ann_expr-  | not float_me+  |  notWorthFloating expr abs_vars+  || not float_me   || floatTopLvlOnly env && not (isTopLvl dest_lvl)          -- Only floating to the top level is allowed.   || hasFreeJoin env fvs   -- If there is a free join, don't float@@ -623,9 +624,6 @@          -- We can't let-bind an expression if we don't know          -- how it will be represented at runtime.          -- See Note [Representation polymorphism invariants] in GHC.Core-  || notWorthFloating expr abs_vars-         -- Test notWorhtFloating last;-         -- See Note [Large free-variable sets]   = -- Don't float it out     lvlExpr env ann_expr @@ -698,11 +696,14 @@          -- A decision to float entails let-binding this thing, and we only do         -- that if we'll escape a value lambda, or will go to the top level.+        -- Never float trivial expressions;+        --   notably, save_work might be true of a lone evaluated variable.     float_me = saves_work || saves_alloc || is_mk_static      -- See Note [Saving work]+    is_hnf = exprIsHNF expr     saves_work = escapes_value_lam        -- (a)-                 && not (exprIsHNF expr)  -- (b)+                 && not is_hnf            -- (b)                  && not float_is_new_lam  -- (c)     escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) @@ -710,7 +711,7 @@     saves_alloc =  isTopLvl dest_lvl                 && floatConsts env                 && (   not strict_ctxt                     -- (a)-                    || exprIsHNF expr                      -- (b)+                    || is_hnf                              -- (b)                     || (is_bot_lam && escapes_value_lam))  -- (c)  hasFreeJoin :: LevelEnv -> DVarSet -> Bool@@ -807,7 +808,7 @@ * We don't pay an allocation cost for the floated expression; it   just becomes static data. -* Floating string literal is valuable -- no point in duplicating the+* Floating string literals is valuable -- no point in duplicating the   at each call site!  * Floating bottoming expressions is valuable: they are always cold@@ -868,28 +869,6 @@ important in some nofib programs (gcd is an example).  [SPJ note: I think this is obsolete; the flag seems always on.] -Note [Large free-variable sets]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In #24471 we had something like-     x1 = I# 1-     ...-     x1000 = I# 1000-     foo = f x1 (f x2 (f x3 ....))-So every sub-expression in `foo` has lots and lots of free variables.  But-none of these sub-expressions float anywhere; the entire float-out pass is a-no-op.--In lvlMFE, we want to find out quickly if the MFE is not-floatable; that is-the common case.  In #24471 it turned out that we were testing `abs_vars` (a-relatively complicated calculation that takes at least O(n-free-vars) time to-compute) for every sub-expression.--Better instead to test `float_me` early. That still involves looking at-dest_lvl, which means looking at every free variable, but the constant factor-is a lot better.--ToDo: find a way to fix the bad asymptotic complexity.- Note [Floating join point bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Mostly we don't float join points at all -- we want them to /stay/ join points.@@ -1135,7 +1114,6 @@ either, so fusion will happen.  It can be a big effect, esp in some artificial benchmarks (e.g. integer, queens), but there is no perfect answer.- -}  annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id@@ -1152,69 +1130,133 @@   = id  notWorthFloating :: CoreExpr -> [Var] -> Bool--- Returns True if the expression would be replaced by--- something bigger than it is now.  For example:---   abs_vars = tvars only:  return True if e is trivial,---                           but False for anything bigger---   abs_vars = [x] (an Id): return True for trivial, or an application (f x)---                           but False for (f x x)------ One big goal is that floating should be idempotent.  Eg if--- we replace e with (lvl79 x y) and then run FloatOut again, don't want--- to replace (lvl79 x y) with (lvl83 x y)!-+--  See Note [notWorthFloating] notWorthFloating e abs_vars-  = go e (count isId abs_vars)+  = go e 0   where-    go (Var {}) n               = n >= 0-    go (Lit lit) n              = assert (n==0) $-                                  litIsTrivial lit   -- Note [Floating literals]-    go (Type {}) _              = True-    go (Coercion {}) _          = True+    n_abs_vars = count isId abs_vars  -- See (NWF5)++    go :: CoreExpr -> Int -> Bool+    -- (go e n) return True if (e x1 .. xn) is not worth floating+    -- where `e` has n trivial value arguments x1..xn+    -- See (NWF4)+    go (Lit lit) n         = (n==0)                 -- See (NWF1b)+                              && litIsTrivial lit   -- See (NWF1a)+    go (Type {}) _         = True+    go (Tick t e) n        = not (tickishIsCode t) && go e n+    go (Cast e _) n        = n==0 || go e n     -- See (NWF3)+    go (Coercion {}) _     = True     go (App e arg) n-       -- See Note [Floating applications to coercions]-       | not (isRuntimeArg arg) = go e n-       | n==0                   = False-       | exprIsTrivial arg      = go e (n-1) -- NB: exprIsTrivial arg = go arg 0-       | otherwise              = False-    go (Tick t e) n             = not (tickishIsCode t) && go e n-    go (Cast e _)  n            = go e n-    go (Case e b _ as) n+       | Type {} <- arg    = go e n    -- Just types, not coercions (NWF2)+       | exprIsTrivial arg = go e (n+1)+       | otherwise         = n==0 && exprIsUnaryClassFun e+                             -- (f non-triv) is worth floating,+                             -- unless if is a unary class fun+    go (Case e b _ as) _+      -- Do not float the `case` part of trivial cases (NWF3)+      -- We'll have a look at the RHS when we get there       | null as-      = go e n     -- See Note [Empty case is trivial]-      | Just rhs <- isUnsafeEqualityCase e b as-      = go rhs n   -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce-    go _ _                      = False+      = True   -- See Note [Empty case is trivial]+      | Just {} <- isUnsafeEqualityCase e b as+      = True   -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+      | otherwise+      = False -{--Note [Floating literals]-~~~~~~~~~~~~~~~~~~~~~~~~-It's important to float Integer literals, so that they get shared,-rather than being allocated every time round the loop.-Hence the litIsTrivial.+    go (Var v) n+      | isUnaryClassId v = n==1   -- (op x) is not worth floating, but (op x y) is!!+                                  --    See (NWF3)+      | n==0             = True   -- Naked variable+      | n <= n_abs_vars  = True   -- (f a b c) is not worth floating if+      | otherwise        = False  -- a,b,c are all abstracted; see (NWF5) -Ditto literal strings (LitString), which we'd like to float to top-level, which is now possible.+    go _ _ = False  -- Let etc is worth floating -Note [Floating applications to coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don’t float out variables applied only to type arguments, since the-extra binding would be pointless: type arguments are completely erased.-But *coercion* arguments aren’t (see Note [Coercion tokens] in-"GHC.CoreToStg" and Note [Count coercion arguments in boring contexts] in-"GHC.Core.Unfold"), so we still want to float out variables applied only to-coercion arguments.+{- Note [notWorthFloating]+~~~~~~~~~~~~~~~~~~~~~~~~~~+`notWorthFloating` returns True if the expression would be replaced by something+bigger than it is now.  One big goal is that floating should be idempotent.  Eg+if we replace e with (lvl79 x y) and then run FloatOut again, don't want to+replace (lvl79 x y) with (lvl83 x y)! +For example:+  abs_vars = tvars only:  return True if e is trivial,+                          but False for anything bigger+  abs_vars = [x] (an Id): return True for trivial, or an application (f x)+                          but False for (f x x) -************************************************************************-*                                                                      *-\subsection{Bindings}-*                                                                      *-************************************************************************+(NWF1a) It's important to float Integer literals, so that they get shared, rather+  than being allocated every time round the loop.  Hence the litIsTrivial. -The binding stuff works for top level too.+  Ditto literal strings (LitString), which we'd like to float to top+  level, which is now possible.++(NWF1b) You might think that a literal should never be applied to a value+  (hence n=0) but actually we can get (see test T23024):+      RUBBISH @(a->b) (x::a)+  See Note [Rubbish literals] in GHC.Types.Literal.  (Mind you, we should be+  in dead code at this point!)++(NWF2) We don’t float out variables applied only to type arguments, since the+  extra binding would be pointless: type arguments are completely erased.+  But *coercion* arguments aren’t (see Note [Coercion tokens] in+  "GHC.CoreToStg" and Note [inlineBoringOk] in"GHC.Core.Unfold"),+  so we still want to float out variables applied only to+  coercion arguments.++(NWF3) Some expressions have trivial wrappers:+     - Casts (e |> co)+     - Unary-class applications:+          - Dictionary applications (MkC meth)+          - Class-op applictions    (op dict)+     - Case of empty alts+     - Unsafe-equality case+  In all these cases we say "not worth floating", and we do so /regardless/+  of the wrapped expression.  The SetLevels stuff may subsequently float the+  components of the expression.++  Example:  is it worth floating (f x |> co)?  No!  If we did we'd get+     lvl = f x |> co+     ...lvl....+  Then we'd do cast worker/wrapper and end up with.+     lvl' = f x+     ...(lvl' |> co)...+  Silly!  Better not to float it in the first place.  If we say "no" here,+  we'll subsequently say "yes" for (f x) and get+     lvl = f x+     ....(lvl |> co)...+  which is what we want.  In short: don't float trivial wrappers.++(NWF4) The only non-trivial expression that we say "not worth floating" for+  is an application+             f x y z+  where the number of value arguments is <= the number of abstracted Ids.+  This is what makes floating idempotent.  Hence counting the number of+  value arguments in `go`++(NWF5) In #24471 we had something like+     x1 = I# 1+     ...+     x1000 = I# 1000+     foo = f x1 (f x2 (f x3 ....))+  So every sub-expression in `foo` has lots and lots of free variables.  But+  none of these sub-expressions float anywhere; the entire float-out pass is a+  no-op.++  So `notWorthFloating` tries to avoid evaluating `n_abs_vars`, in cases where+  it obviously /is/ worth floating.  (In #24471 it turned out that we were+  testing `abs_vars` (a relatively complicated calculation that takes at least+  O(n-free-vars) time to compute) for every sub-expression.)++  Hence testing `n_abs_vars only` at the very end. -} +{- *********************************************************************+*                                                                      *+                       Bindings+        This binding stuff works for top level too.+*                                                                      *+********************************************************************* -}+ lvlBind :: LevelEnv         -> CoreBindWithFVs         -> LvlM (LevelledBind, LevelEnv)@@ -1854,7 +1896,7 @@ cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })                new_lvl vs-  = do { (subst', vs') <- cloneBndrs subst vs+  = do { (subst', vs') <- cloneBndrsM subst vs              -- N.B. We are not moving the body of the case, merely its case              -- binders.  Consequently we should *not* set le_ctxt_lvl.              -- See Note [Setting levels when floating single-alternative cases].@@ -1875,8 +1917,8 @@           dest_lvl vs   = do { let vs1  = map zap vs        ; (subst', vs2) <- case is_rec of-                            NonRecursive -> cloneBndrs      subst vs1-                            Recursive    -> cloneRecIdBndrs subst vs1+                            NonRecursive -> cloneBndrsM      subst vs1+                            Recursive    -> cloneRecIdBndrsM subst vs1         ; let prs  = vs `zip` vs2              env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE CPP, LambdaCase #-}-#if __GLASGOW_HASKELL__ < 905-{-# LANGUAGE PatternSynonyms #-}-#endif+{-# LANGUAGE LambdaCase #-} {- ToDo [Oct 2013] ~~~~~~~~~~~~~~~@@ -14,10 +11,6 @@ \section[SpecConstr]{Specialise over constructors} -} ---{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Core.Opt.SpecConstr(         specConstrProgram,         SpecConstrAnnotation(..),@@ -42,7 +35,7 @@ import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules-import GHC.Core.Predicate ( typeDeterminesValue )+import GHC.Core.Predicate ( scopedSort, typeDeterminesValue ) import GHC.Core.Type     hiding ( substTy ) import GHC.Core.TyCon   (TyCon, tyConName ) import GHC.Core.Multiplicity@@ -68,7 +61,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique( hasKey ) -import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing )+import GHC.Data.Maybe     ( fromMaybe, orElse, catMaybes, isJust, isNothing ) import GHC.Data.FastString  import GHC.Utils.Misc@@ -84,6 +77,7 @@  import Control.Monad import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL )+import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Maybe( mapMaybe ) import Data.Ord( comparing ) import Data.Tuple@@ -1042,16 +1036,7 @@ scSubstId env v = lookupIdSubst (sc_subst env) v  --- Solo is only defined in base starting from ghc-9.2-#if !(MIN_VERSION_base(4, 16, 0))-data Solo a = Solo a-#endif --- The Solo constructor was renamed to MkSolo in ghc 9.5-#if __GLASGOW_HASKELL__ < 905-pattern MkSolo :: a -> Solo a-pattern MkSolo a = Solo a-#endif  -- The !subst ensures that we force the selection `(sc_subst env)`, which avoids -- retaining all of `env` when we only need `subst`.  The `Solo` means that the@@ -1314,13 +1299,12 @@                            scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }  combineUsages :: [ScUsage] -> ScUsage-combineUsages [] = nullUsage-combineUsages us = foldr1 combineUsage us+combineUsages = foldr1WithDefault nullUsage combineUsage -lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])+lookupOccs :: Traversable f => ScUsage -> f OutVar -> (ScUsage, f ArgOcc) lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs   = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},-     [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])+    fromMaybe NoOcc . lookupVarEnv sc_occs <$> bndrs)  data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument             | UnkOcc    -- Used in some unknown way@@ -1383,7 +1367,7 @@ combineOcc UnkOcc        UnkOcc        = UnkOcc  combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]-combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys+combineOccs xs ys = zipWithEqual combineOcc xs ys  setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee@@ -1490,7 +1474,7 @@          ; let all_usg = (spec_usg `combineUsage` body_usg)  -- Note [spec_usg includes rhs_usg]                         `delCallsFor` bndrs'-              bind'   = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))+              bind'   = Rec (concat (zipWithEqual ruleInfoBinds rhs_infos specs))                         -- zipWithEqual: length of returned [SpecInfo]                         -- should be the same as incoming [RhsInfo] @@ -1596,7 +1580,7 @@      = do { let (env1, bs1) = extendBndrsWith RecArg env bs                 (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1           ; (usg, rhs', ws) <- scExpr env2 rhs-          ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)+          ; let (usg', b_occ:|arg_occs) = lookupOccs usg (b':|bs2)                 scrut_occ = case con of                                DataAlt dc -- See Note [Do not specialise evals]                                   | not (single_alt && all deadArgOcc arg_occs)@@ -2465,7 +2449,7 @@               good_pats :: [CallPat]               good_pats = catMaybes mb_pats -              in_scope = getSubstInScope (sc_subst env)+              in_scope = substInScopeSet (sc_subst env)                -- Remove patterns we have already done               new_pats = filterOut is_done good_pats@@ -2512,35 +2496,32 @@     partitionByWorkerSize worker_size pats = go pats [] []       where         go [] small warnings = (small, warnings)-        go (p:ps) small warnings-          | WorkerSmallEnough <- worker_size p-          = go ps (p:small) warnings-          | WorkerTooLarge <- worker_size p-          = go ps small warnings-          | WorkerTooLargeForced name <- worker_size p-          = go ps small (SpecFailForcedArgCount name : warnings)+        go (p:ps) small warnings =+          case worker_size p of+            WorkerSmallEnough -> go ps (p:small) warnings+            WorkerTooLarge -> go ps small warnings+            WorkerTooLargeForced name -> go ps small (SpecFailForcedArgCount name : warnings)   trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat]) -- True <=> some patterns were discarded -- See Note [Choosing patterns] trim_pats env fn (SI { si_n_specs = done_spec_count }) pats-  | sc_force env-    || isNothing mb_scc-    || n_remaining >= n_pats-  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)-    (False, pats)          -- No need to trim+  | False <- sc_force env+  , Just max_specs <- mb_scc+  , let n_remaining = max_specs - done_spec_count+  , n_remaining < n_pats+  = emit_trace max_specs n_remaining $  -- Need to trim, so keep the best ones+    (True, take n_remaining sorted_pats)    | otherwise-  = emit_trace $  -- Need to trim, so keep the best ones-    (True, take n_remaining sorted_pats)+  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)+    (False, pats)          -- No need to trim    where     n_pats         = length pats     spec_count'    = n_pats + done_spec_count-    n_remaining    = max_specs - done_spec_count     mb_scc         = sc_count $ sc_opts env-    Just max_specs = mb_scc      sorted_pats = map fst $                   sortBy (comparing snd) $@@ -2563,21 +2544,24 @@           n_cons (Lit {})    = 1           n_cons _           = 0 -    emit_trace result+    emit_trace max_specs n_remaining result        | debugIsOn || sc_debug (sc_opts env)          -- Suppress this scary message for ordinary users!  #5125        = pprTrace "SpecConstr" msg result        | otherwise        = result-    msg = vcat [ sep [ text "Function" <+> quotes (ppr fn)-                     , nest 2 (text "has" <+>-                               speakNOf spec_count' (text "call pattern") <> comma <+>-                               text "but the limit is" <+> int max_specs) ]-               , text "Use -fspec-constr-count=n to set the bound"-               , text "done_spec_count =" <+> int done_spec_count-               , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats-               , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]-+      where+        msg = vcat+          [ sep+              [ text "Function" <+> quotes (ppr fn)+              , nest 2+                  ( text "has" <+>+                    speakNOf spec_count' (text "call pattern") <> comma <+>+                    text "but the limit is" <+> int max_specs ) ]+          , text "Use -fspec-constr-count=n to set the bound"+          , text "done_spec_count =" <+> int done_spec_count+          , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats+          , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]  callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)         -- The [Var] is the variables to quantify over in the rule@@ -2585,7 +2569,7 @@         --      over the following term variables         -- The [CoreExpr] are the argument patterns for the rule callToPat env bndr_occs call@(Call fn args con_env)-  = do  { let in_scope = getSubstInScope (sc_subst env)+  = do  { let in_scope = substInScopeSet (sc_subst env)          ; arg_triples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)                    -- This zip trims the args to be no longer than@@ -2842,8 +2826,11 @@                -- but that doesn't take account of which branch of a                -- case we are in, which is the whole point -  | not (isLocalId v) && isCheapUnfolding unf-  = isValue env (unfoldingTemplate unf)+  | not (isLocalId v)+  , isCheapUnfolding unf+  , Just rhs <- maybeUnfoldingTemplate unf  -- Succeds if isCheapUnfolding does+  = isValue env rhs   -- Can't use isEvaldUnfolding because+                      -- we want to consult the `env`   where     unf = idUnfolding v         -- However we do want to consult the unfolding
compiler/GHC/Core/Opt/Specialise.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE MultiWayIf #-}  {- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998@@ -16,9 +16,9 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts )  import GHC.Core.Type  hiding( substTy, substCo, extendTvSubst, zapSubst )-import GHC.Core.Multiplicity-import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith )+import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) import GHC.Core.Predicate+import GHC.Core.Class( classMethods ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad import qualified GHC.Core.Subst as Core@@ -28,16 +28,14 @@ import GHC.Core.Unify     ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils     ( exprIsTrivial, exprIsTopLevelBindable-                          , mkCast, exprType+                          , mkCast, exprType, exprIsHNF                           , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs-import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Core.Opt.Arity( collectBindersPushingCo )--- import GHC.Core.Ppr( pprIds )  import GHC.Builtin.Types  ( unboxedUnitTy ) -import GHC.Data.Maybe     ( maybeToList, isJust )+import GHC.Data.Maybe     ( isJust ) import GHC.Data.Bag import GHC.Data.OrdList import GHC.Data.List.SetOps@@ -48,7 +46,7 @@ import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Id.Make  ( voidArgId, voidPrimId )-import GHC.Types.Var      ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar )+import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id@@ -58,6 +56,7 @@ import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad    ( foldlM ) import GHC.Utils.Misc+import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Panic @@ -68,6 +67,8 @@ import Data.List( partition ) import Data.List.NonEmpty ( NonEmpty (..) ) import GHC.Core.Subst (substTickish)+import GHC.Core.TyCon (tyConClass_maybe)+import GHC.Core.DataCon (dataConTyCon)  {- ************************************************************************@@ -1202,14 +1203,21 @@ ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {})   = do { let (fun_in, args_in) = collectArgs expr+       ; (fun_out, uds_fun)   <- specExpr env fun_in        ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in-       ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args-                -- Some dicts may have floated out of args_in;-                -- they should be in scope for fireRewriteRules (#21689)-             (fun_in', args_out') = fireRewriteRules env_args fun_in args_out-       ; (fun_out', uds_fun) <- specExpr env fun_in'+       ; let uds_app  = uds_fun `thenUDs` uds_args+             env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app+                -- zapSubst: we have now fully applied the substitution+                -- bringFloatedDictsIntoScope: some dicts may have floated out of+                -- args_in; they should be in scope for fireRewriteRules (#21689)++       -- Try firing rewrite rules+       -- See Note [Fire rules in the specialiser]+       ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out++       -- Make a call record, and return        ; let uds_call = mkCallUDs env fun_out' args_out'-       ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) }+       ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) }  ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {})@@ -1243,16 +1251,18 @@ -- See Note [Specialisation modulo dictionary selectors] --     Note [ClassOp/DFun selection] --     Note [Fire rules in the specialiser]-fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr])+fireRewriteRules :: SpecEnv   -- Substitution is already zapped+                 -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) fireRewriteRules env (Var f) args-  | Just (rule, expr) <- specLookupRule env f args InitialPhase (getRules (se_rules env) f)+  | let rules = getRules (se_rules env) f+  , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules   , let rest_args    = drop (ruleArity rule) args -- See Note [Extra args in the target]-        zapped_subst = Core.zapSubst (se_subst env)-        expr'        = simpleOptExprWith defaultSimpleOpts zapped_subst expr+        zapped_subst = se_subst env   -- Just needed for the InScopeSet+        expr'        = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args)                        -- simplOptExpr needed because lookupRule returns                        --   (\x y. rhs) arg1 arg2-  , (fun, args) <- collectArgs expr'-  = fireRewriteRules env fun (args++rest_args)+  , (fun', args') <- collectArgs expr'+  = fireRewriteRules env fun' args' fireRewriteRules _ fun args = (fun, args)  --------------@@ -1280,7 +1290,8 @@                   , UsageDetails) specCase env scrut' case_bndr [Alt con args rhs]   | -- See Note [Floating dictionaries out of cases]-    interestingDict scrut' (idType case_bndr)+    isDictTy (idType case_bndr)+  , interestingDict env scrut'   , not (isDeadBinder case_bndr && null sc_args')   = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args') @@ -1318,7 +1329,7 @@ --       ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $        ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }   where-    (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)+    (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args)     sc_args' = filter is_flt_sc_arg args'      clone_me bndr = do { uniq <- getUniqueM@@ -1338,7 +1349,6 @@        where          var_ty = idType var - specCase env scrut case_bndr alts   = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts        ; return (scrut, case_bndr', alts', uds_alts) }@@ -1355,6 +1365,7 @@         where           (env_rhs, args') = substBndrs env_alt args + {- Note [Fire rules in the specialiser] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (#21851)@@ -1379,9 +1390,9 @@ The call to `g` in `h` will make us specialise `g @Int`. And the specialised version of `g` will contain the call `f @Int`; but in the subsequent run of the Simplifier, there will be a competition between:-* The user-supplied SPECIALISE rule for `f`-* The inlining of the wrapper for `f`-In fact, the latter wins -- see Note [Rewrite rules and inlining] in+  * The user-supplied SPECIALISE rule for `f`+  * The inlining of the wrapper for `f`+In fact, the latter wins -- see Note [tryRules: plan (BEFORE)] GHC.Core.Opt.Simplify.Iteration.  However, it a bit fragile.  Moreover consider (test T21851_2):@@ -1410,11 +1421,10 @@ we load it up just once, in `initRuleEnv`, called at the beginning of `specProgram`. -NB: you might wonder if running rules in the specialiser (this Note)-renders Note [Rewrite rules and inlining] in the Simplifier redundant.-That is, if we run rules in the specialiser, does it matter if we make-rules "win" over inlining in the Simplifier?  Yes, it does!  See the-discussion in #21851.+NB: you might wonder if running rules in the specialiser (this Note) renders+Note [tryRules: plan (BEFORE)] in the Simplifier (partly) redundant.  That is,+if we run rules in the specialiser, does it matter if we make rules "win" over+inlining in the Simplifier?  Yes, it does!  See the discussion in #21851.  Note [Floating dictionaries out of cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1623,7 +1633,7 @@  -- This function checks existing rules, and does not create -- duplicate ones. So the caller does not need to do this filtering.--- See 'already_covered'+-- See `alreadyCovered`  type SpecInfo = ( [CoreRule]       -- Specialisation rules                 , [(Id,CoreExpr)]  -- Specialised definition@@ -1646,16 +1656,14 @@ --      switch off specialisation for inline functions    = -- pprTrace "specCalls: some" (vcat-    --   [ text "function" <+> ppr fn-    --   , text "calls:" <+> ppr calls_for_me-    --   , text "subst" <+> ppr (se_subst env) ]) $+    --  [ text "function" <+> ppr fn+    --  , text "calls:" <+> ppr calls_for_me+    --  , text "subst" <+> ppr (se_subst env) ]) $     foldlM spec_call ([], [], emptyUDs) calls_for_me    | otherwise   -- No calls or RHS doesn't fit our preconceptions-  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))+  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)           "Missed specialisation opportunity for" (ppr fn $$ trace_doc) $-          -- isClassOpId: class-op Ids never inline; we specialise them-          -- through fireRewriteRules. So don't complain about missed opportunities           -- Note [Specialisation shape]     -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $     return ([], [], emptyUDs)@@ -1667,26 +1675,34 @@     fn_unf    = realIdUnfolding fn  -- Ignore loop-breaker-ness here     inl_prag  = idInlinePragma fn     inl_act   = inlinePragmaActivation inl_prag+    is_active = isActive (beginPhase inl_act) :: Activation -> Bool+         -- is_active: inl_act is the activation we are going to put in the new+         --   SPEC rule; so we want to see if it is covered by another rule with+         --   that same activation.     is_local  = isLocalId fn     is_dfun   = isDFunId fn     dflags    = se_dflags env     this_mod  = se_module env+    subst     = se_subst env+    in_scope  = Core.substInScopeSet subst         -- Figure out whether the function has an INLINE pragma         -- See Note [Inline specialisations]      (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs                             -- See Note [Account for casts in binding] -    already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool-    already_covered env new_rules args      -- Note [Specialisations already covered]-       = isJust (specLookupRule env fn args (beginPhase inl_act)-                                (new_rules ++ existing_rules))-         -- Rules: we look both in the new_rules (generated by this invocation-         --   of specCalls), and in existing_rules (passed in to specCalls)-         -- inl_act: is the activation we are going to put in the new SPEC-         --   rule; so we want to see if it is covered by another rule with-         --   that same activation.+    -- Copy InlinePragma information from the parent Id.+    -- So if f has INLINE[1] so does spec_fn+    spec_inl_prag+      | not is_local     -- See Note [Specialising imported functions]+      , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal+      = neverInlinePragma+      | otherwise+      = inl_prag +    not_in_scope :: InterestingVarFun+    not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope)+     ----------------------------------------------------------         -- Specialise to one particular call pattern     spec_call :: SpecInfo                         -- Accumulating parameter@@ -1698,57 +1714,92 @@                                | otherwise = call_args                  saturating_call_args = call_args ++ map mk_extra_dfun_arg (dropList call_args rhs_bndrs)                  mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType-                                        | otherwise = UnspecArg+                                        | otherwise    = UnspecArg -           ; ( useful, rhs_env2, leftover_bndrs-             , rule_bndrs, rule_lhs_args-             , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args+             -- Find qvars, the type variables to add to the binders for the rule+             -- Namely those free in `ty` that aren't in scope+             -- See (MP2) in Note [Specialising polymorphic dictionaries]+           ; let poly_qvars = scopedSort $ fvVarList $ specArgsFVs not_in_scope call_args+                 subst'     = subst `Core.extendSubstInScopeList` poly_qvars+                              -- Maybe we should clone the poly_qvars telescope? ---           ; pprTrace "spec_call" (vcat---                [ text "fun:       "  <+> ppr fn---                , text "call info: "  <+> ppr _ci---                , text "useful:    "  <+> ppr useful---                , text "rule_bndrs:"  <+> ppr rule_bndrs---                , text "lhs_args:  "  <+> ppr rule_lhs_args---                , text "spec_bndrs1:" <+> ppr spec_bndrs1---                , text "leftover_bndrs:" <+> pprIds leftover_bndrs---                , text "spec_args: "  <+> ppr spec_args---                , text "dx_binds:  "  <+> ppr dx_binds---                , text "rhs_bndrs"     <+> ppr rhs_bndrs---                , text "rhs_body"     <+> ppr rhs_body---                , text "rhs_env2:  "  <+> ppr (se_subst rhs_env2)---                , ppr dx_binds ]) $---             return ()+             -- Any free Ids will have caused the call to be dropped+           ; massertPpr (all isTyCoVar poly_qvars)+                        (ppr fn $$ ppr all_call_args $$ ppr poly_qvars) -           ; if not useful  -- No useful specialisation-                || already_covered rhs_env2 rules_acc rule_lhs_args+           ; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args)+                 <- specHeader subst' rhs_bndrs all_call_args+           ; let all_rule_bndrs = poly_qvars ++ rule_bndrs+                 env' = env { se_subst = subst'' }++           -- Check for (a) usefulness and (b) not already covered+           -- See (SC1) in Note [Specialisations already covered]+           ; let all_rules = rules_acc ++ existing_rules+                 -- all_rules: we look both in the rules_acc (generated by this invocation+                 --   of specCalls), and in existing_rules (passed in to specCalls)+                 already_covered = alreadyCovered env' all_rule_bndrs fn+                                                  rule_lhs_args is_active all_rules++{-         ; pprTrace "spec_call" (vcat+                [ text "fun:       "  <+> ppr fn+                , text "call info: "  <+> ppr _ci+                , text "useful:    "  <+> ppr useful+                , text "already_covered:"  <+> ppr already_covered+                , text "poly_qvars: " <+> ppr poly_qvars+                , text "useful:    "  <+> ppr useful+                , text "all_rule_bndrs:"  <+> ppr all_rule_bndrs+                , text "rule_lhs_args:"  <+> ppr rule_lhs_args+                , text "spec_bndrs:" <+> ppr spec_bndrs+                , text "dx_binds:"   <+> ppr dx_binds+                , text "spec_args: "  <+> ppr spec_args+                , text "rhs_bndrs"    <+> ppr rhs_bndrs+                , text "rhs_body"     <+> ppr rhs_body+                , text "subst''" <+> ppr subst'' ]) $+             return ()+-}++           ; if not useful          -- No useful specialisation+                || already_covered  -- Useful, but done already              then return spec_acc              else-        do { -- Run the specialiser on the specialised RHS-             -- The "1" suffix is before we maybe add the void arg-           ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body-                -- Add the { d1' = dx1; d2' = dx2 } usage stuff-                -- to the rhs_uds; see Note [Specialising Calls]-           ; let rhs_uds_w_dx   = dx_binds `consDictBinds` rhs_uds-                 spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs-                 (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx-                 spec_rhs1 = mkLams spec_rhs_bndrs $-                             wrapDictBindsE dumped_dbs rhs_body' -                 spec_fn_ty1 = exprType spec_rhs1+        -- Not useless, not already covered: make a specialised binding+        do { let inner_rhs_bndrs = dropList all_call_args rhs_bndrs+                 (env'', inner_rhs_bndrs') = substBndrs env' inner_rhs_bndrs +             -- Run the specialiser on the specialised RHS+           ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body++{-         ; pprTrace "spec_call2" (vcat+                 [ text "fun:" <+> ppr fn+                 , text "rhs_body':" <+> ppr rhs_body' ]) $+             return ()+-}++           -- Make the RHS of the specialised function+           ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs'+                 (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds+                 (rhs_uds2, outer_dumped_dbs) = dumpUDs poly_qvars (dx_binds `consDictBinds` rhs_uds1)+                 -- dx_binds comes from the arguments to the call, and so can mention+                 -- poly_qvars but no other local binders+                 spec_rhs = mkLams poly_qvars               $+                            wrapDictBindsE outer_dumped_dbs $+                            mkLams spec_rhs_bndrs           $+                            wrapDictBindsE inner_dumped_dbs rhs_body'+                 rule_rhs_args = poly_qvars ++ spec_bndrs+                  -- Maybe add a void arg to the specialised function,                  -- to avoid unlifted bindings                  -- See Note [Specialisations Must Be Lifted]                  -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg-                 add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)-                 (spec_bndrs, spec_rhs, spec_fn_ty)-                   | add_void_arg = ( voidPrimId : spec_bndrs1-                                    , Lam voidArgId spec_rhs1-                                    , mkVisFunTyMany unboxedUnitTy spec_fn_ty1)-                   | otherwise   = (spec_bndrs1, spec_rhs1, spec_fn_ty1) -                 join_arity_decr = length rule_lhs_args - length spec_bndrs+                 spec_fn_ty = exprType spec_rhs+                 add_void_arg = isUnliftedType spec_fn_ty && not (isJoinId fn)+                 (rule_rhs_args1, spec_rhs1, spec_fn_ty1)+                   | add_void_arg = ( voidPrimId : rule_rhs_args+                                    , Lam voidArgId spec_rhs+                                    , mkVisFunTyMany unboxedUnitTy spec_fn_ty )+                   | otherwise    = (rule_rhs_args, spec_rhs, spec_fn_ty)                   --------------------------------------                  -- Add a suitable unfolding; see Note [Inline specialisations]@@ -1756,22 +1807,14 @@                  -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)                  simpl_opts = initSimpleOpts dflags                  wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds-                 spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body+                 spec_unf = specUnfolding simpl_opts rule_rhs_args1 wrap_unf_body                                           rule_lhs_args fn_unf                   --------------------------------------                  -- Adding arity information just propagates it a bit faster                  --      See Note [Arity decrease] in GHC.Core.Opt.Simplify-                 -- Copy InlinePragma information from the parent Id.-                 -- So if f has INLINE[1] so does spec_fn-                 arity_decr     = count isValArg rule_lhs_args - count isId spec_bndrs--                 spec_inl_prag-                   | not is_local     -- See Note [Specialising imported functions]-                   , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal-                   = neverInlinePragma-                   | otherwise-                   = inl_prag+                 join_arity_decr = length rule_lhs_args         - length rule_rhs_args1+                 arity_decr      = count isValArg rule_lhs_args - count isId rule_rhs_args1                   spec_fn_info                    = vanillaIdInfo `setArityInfo`      max 0 (fn_arity - arity_decr)@@ -1783,10 +1826,10 @@                  spec_fn_details                    = case idDetails fn of                        JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing-                       DFunId is_nt        -> DFunId is_nt+                       DFunId unary        -> DFunId unary                        _                   -> VanillaId -           ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info+           ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty1 spec_fn_details spec_fn_info            ; let                 -- The rule to put in the function's specialisation is:                 --      forall x @b d1' d2'.@@ -1798,36 +1841,56 @@                                      text "SPEC"                  spec_rule = mkSpecRule dflags this_mod True inl_act-                                    herald fn rule_bndrs rule_lhs_args-                                    (mkVarApps (Var spec_fn) spec_bndrs)--                spec_f_w_arity = spec_fn+                                    herald fn all_rule_bndrs rule_lhs_args+                                    (mkVarApps (Var spec_fn) rule_rhs_args1)                  _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type-                                       , ppr spec_fn  <+> dcolon <+> ppr spec_fn_ty+                                       , ppr spec_fn  <+> dcolon <+> ppr spec_fn_ty1                                        , ppr rhs_bndrs, ppr call_args                                        , ppr spec_rule+                                       , text "acc" <+> ppr rules_acc+                                       , text "existing" <+> ppr existing_rules                                        ]             ; -- pprTrace "spec_call: rule" _rule_trace_doc-             return ( spec_rule                  : rules_acc-                    , (spec_f_w_arity, spec_rhs) : pairs_acc-                    , spec_uds           `thenUDs` uds_acc+             return ( spec_rule            : rules_acc+                    , (spec_fn, spec_rhs1) : pairs_acc+                    , rhs_uds2 `thenUDs` uds_acc                     ) } } +alreadyCovered :: SpecEnv+               -> [Var] -> Id -> [CoreExpr]   -- LHS of possible new rule+               -> (Activation -> Bool)        -- Which rules are active+               -> [CoreRule] -> Bool+-- Note [Specialisations already covered] esp (SC2)+alreadyCovered env bndrs fn args is_active rules+  = case specLookupRule env fn args is_active rules of+      Nothing             -> False+      Just (rule, _)+        | isAutoRule rule -> -- Discard identical rules+                             -- We know that (fn args) is an instance of RULE+                             -- Check if RULE is an instance of (fn args)+                             ruleLhsIsMoreSpecific in_scope bndrs args rule+        | otherwise       -> True  -- User rules dominate+  where+    in_scope = substInScopeSet (se_subst env)+ -- Convenience function for invoking lookupRule from Specialise -- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]-specLookupRule :: SpecEnv -> Id -> [CoreExpr]-               -> CompilerPhase  -- Look up rules as if we were in this phase+specLookupRule :: HasDebugCallStack+               => SpecEnv -> Id -> [CoreExpr]+               -> (Activation -> Bool)  -- Which rules are active                -> [CoreRule] -> Maybe (CoreRule, CoreExpr)-specLookupRule env fn args phase rules+specLookupRule env fn args is_active rules+  | null rules+  = Nothing    -- Saves building a few thunks in the common case+  | otherwise   = lookupRule ropts in_scope_env is_active fn args rules   where     dflags       = se_dflags env-    in_scope     = getSubstInScope (se_subst env)+    in_scope     = substInScopeSet (se_subst env)     in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active)     ropts        = initRuleOpts dflags-    is_active    = isActive phase  {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1947,12 +2010,15 @@  and suppose it is called at: -    f 7 @T1 @T2 @T3 dEqT1 ($dfShow dShowT2) t3+    f @T1 @T2 @T3 7 dEqT1 ($dfShow dShowT2) t3  This call is described as a 'CallInfo' whose 'ci_key' is: -    [ SpecType T1, SpecType T2, UnspecType, UnspecArg, SpecDict dEqT1-    , SpecDict ($dfShow dShowT2), UnspecArg ]+    [ SpecType T1, SpecType T2, UnspecType+    , UnspecArg+    , SpecDict dEqT1+    , SpecDict ($dfShow dShowT2)+    , UnspecArg ]  Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? Because we must specialise the function on type variables that appear@@ -2128,17 +2194,20 @@ Note [Evidence foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (#12212) that we are specialising-   f :: forall a b. (Num a, F a ~ F b) => blah+   f :: forall a b. (Num a, F a ~# F b) => blah with a=b=Int. Then the RULE will be something like-   RULE forall (d:Num Int) (g :: F Int ~ F Int).+   RULE forall (d:Num Int) (g :: F Int ~# F Int).         f Int Int d g = f_spec+where that `g` is really (Coercion (CoVar g)), since `g` is a+coercion variable and can't appear as (Var g).+ But both varToCoreExpr (when constructing the LHS args), and the simplifier (when simplifying the LHS args), will transform to    RULE forall (d:Num Int) (g :: F Int ~ F Int).         f Int Int d <F Int> = f_spec by replacing g with Refl.  So now 'g' is unbound, which results in a later crash. So we use Refl right off the bat, and do not forall-quantify 'g':- * varToCoreExpr generates a Refl+ * varToCoreExpr generates a (Coercion Refl)  * exprsFreeIdsList returns the Ids bound by the args,    which won't include g @@ -2326,22 +2395,25 @@ Note [Specialisations already covered] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We obviously don't want to generate two specialisations for the same-argument pattern.  There are two wrinkles+argument pattern.  Wrinkles -1. We do the already-covered test in specDefn, not when we generate-the CallInfo in mkCallUDs.  We used to test in the latter place, but-we now iterate the specialiser somewhat, and the Id at the call site-might therefore not have all the RULES that we can see in specDefn+(SC1) We do the already-covered test in specDefn, not when we generate+    the CallInfo in mkCallUDs.  We used to test in the latter place, but+    we now iterate the specialiser somewhat, and the Id at the call site+    might therefore not have all the RULES that we can see in specDefn -2. What about two specialisations where the second is an *instance*-of the first?  If the more specific one shows up first, we'll generate-specialisations for both.  If the *less* specific one shows up first,-we *don't* currently generate a specialisation for the more specific-one.  (See the call to lookupRule in already_covered.)  Reasons:-  (a) lookupRule doesn't say which matches are exact (bad reason)-  (b) if the earlier specialisation is user-provided, it's-      far from clear that we should auto-specialise further+(SC2) What about two specialisations where the second is an *instance*+   of the first?  It's a bit arbitrary, but here's what we do:+   * If the existing one is user-specified, via a SPECIALISE pragma, we+     suppress the further specialisation.+   * If the existing one is auto-generated, we generate a second RULE+     for the more specialised version.+   The latter is important because we don't want the accidental order+   of calls to determine what specialisations we generate. +(SC3) Annoyingly, we /also/ eliminate duplicates in `filterCalls`.+   See (MP3) in Note [Specialising polymorphic dictionaries]+ Note [Auto-specialisation and RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider:@@ -2478,22 +2550,22 @@   | UnspecArg  instance Outputable SpecArg where-  ppr (SpecType t) = text "SpecType" <+> ppr t-  ppr UnspecType   = text "UnspecType"-  ppr (SpecDict d) = text "SpecDict" <+> ppr d-  ppr UnspecArg    = text "UnspecArg"--specArgFreeIds :: SpecArg -> IdSet-specArgFreeIds (SpecType {}) = emptyVarSet-specArgFreeIds (SpecDict dx) = exprFreeIds dx-specArgFreeIds UnspecType    = emptyVarSet-specArgFreeIds UnspecArg     = emptyVarSet+  ppr (SpecType t)  = text "SpecType" <+> ppr t+  ppr (SpecDict d)  = text "SpecDict" <+> ppr d+  ppr UnspecType    = text "UnspecType"+  ppr UnspecArg     = text "UnspecArg" -specArgFreeVars :: SpecArg -> VarSet-specArgFreeVars (SpecType ty) = tyCoVarsOfType ty-specArgFreeVars (SpecDict dx) = exprFreeVars dx-specArgFreeVars UnspecType    = emptyVarSet-specArgFreeVars UnspecArg     = emptyVarSet+specArgsFVs :: InterestingVarFun -> [SpecArg] -> FV+-- Find the free vars of the SpecArgs that are not already in scope+specArgsFVs interesting args+  = filterFV interesting $+    foldr (unionFV . get) emptyFV args+  where+    get :: SpecArg -> FV+    get (SpecType ty)   = tyCoFVsOfType ty+    get (SpecDict dx)   = exprFVs dx+    get UnspecType      = emptyFV+    get UnspecArg       = emptyFV  isSpecDict :: SpecArg -> Bool isSpecDict (SpecDict {}) = True@@ -2543,103 +2615,90 @@ --    , [T1, T2, c, i, dEqT1, dShow1] --    ) specHeader-     :: SpecEnv-     -> [InBndr]    -- The binders from the original function 'f'+     :: Core.Subst  -- This substitution applies to the [InBndr]+     -> [InBndr]    -- Binders from the original function `f`      -> [SpecArg]   -- From the CallInfo      -> SpecM ( Bool     -- True <=> some useful specialisation happened                          -- Not the same as any (isSpecDict args) because                          -- the args might be longer than bndrs -                -- Returned arguments-              , SpecEnv      -- Substitution to apply to the body of 'f'-              , [OutBndr]    -- Leftover binders from the original function 'f'-                             --   that don’t have a corresponding SpecArg+              , Core.Subst   -- Apply this to the body                  -- RULE helpers-              , [OutBndr]    -- Binders for the RULE-              , [OutExpr]    -- Args for the LHS of the rule+                -- `RULE forall rule_bndrs. f rule_es = $sf spec_bndrs`+              , [OutBndr]    -- rule_bndrs: Binders for the RULE+              , [OutExpr]    -- rule_es:    Args for the LHS of the rule                  -- Specialised function helpers-              , [OutBndr]    -- Binders for $sf-              , [DictBind]   -- Auxiliary dictionary bindings-              , [OutExpr]    -- Specialised arguments for unfolding-                             -- Same length as "Args for LHS of rule"+                -- `$sf = \spec_bndrs. let { dx_binds } in <orig-rhs> spec_arg`+              , [OutBndr]    -- spec_bndrs: Binders for $sf, and args for the RHS+                             --             of the RULE. Subset of rule_bndrs.+              , [DictBind]   -- dx_binds:   Auxiliary dictionary bindings+              , [OutExpr]    -- spec_args:  Specialised arguments for unfolding+                             --             Same length as "Args for LHS of rule"               ) +-- If we run out of binders, stop immediately+-- See Note [Specialisation Must Preserve Sharing]+specHeader subst [] _  = pure (False, subst, [], [], [], [], [])+specHeader subst _  [] = pure (False, subst, [], [], [], [], [])+ -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details.-specHeader env (bndr : bndrs) (SpecType ty : args)-  = do { -- Find qvars, the type variables to add to the binders for the rule-         -- Namely those free in `ty` that aren't in scope-         -- See (MP2) in Note [Specialising polymorphic dictionaries]-         let in_scope = Core.getSubstInScope (se_subst env)-             qvars    = scopedSort $-                        filterOut (`elemInScopeSet` in_scope) $-                        tyCoVarsOfTypeList ty-             (env1, qvars') = substBndrs env qvars-             ty'            = substTy env1 ty-             env2           = extendTvSubst env1 bndr ty'-       ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-            <- specHeader env2 bndrs args-       ; pure ( useful-              , env3-              , leftover_bndrs-              , qvars' ++ rule_bs-              , Type ty' : rule_es-              , qvars' ++ bs'-              , dx-              , Type ty' : spec_args-              )-       }+specHeader subst (bndr:bndrs) (SpecType ty : args)+  = do { let subst1 = Core.extendTvSubst subst bndr ty+       ; (useful, subst2, rule_bs, rule_args, spec_bs, dx, spec_args)+             <- specHeader subst1 bndrs args+       ; pure ( useful, subst2+              , rule_bs,     Type ty : rule_args+              , spec_bs, dx, Type ty : spec_args ) }  -- Next we have a type that we don't want to specialise. We need to perform -- a substitution on it (in case the type refers to 'a'). Additionally, we need -- to produce a binder, LHS argument and RHS argument for the resulting rule, -- /and/ a binder for the specialised body.-specHeader env (bndr : bndrs) (UnspecType : args)-  = do { let (env', bndr') = substBndr env bndr-       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-            <- specHeader env' bndrs args-       ; pure ( useful-              , env''-              , leftover_bndrs-              , bndr' : rule_bs-              , varToCoreExpr bndr' : rule_es-              , bndr' : bs'-              , dx-              , varToCoreExpr bndr' : spec_args-              )-       }+specHeader subst (bndr:bndrs) (UnspecType : args)+  = do { let (subst1, bndr') = Core.substBndr subst bndr+       ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args)+             <- specHeader subst1 bndrs args+       ; let ty_e' = Type (mkTyVarTy bndr')+       ; pure ( useful, subst2+              , bndr' : rule_bs,     ty_e' : rule_es+              , bndr' : spec_bs, dx, ty_e' : spec_args ) } +specHeader subst (bndr:bndrs) (_ : args)+  | isDeadBinder bndr+  , let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr)+  , Just rubbish_lit <- mkLitRubbish (idType bndr')+  = -- See Note [Drop dead args from specialisations]+    do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args+       ; pure ( useful, subst2+              , bndr' : rule_bs, Var bndr'   : rule_es+              , spec_bs,     dx, rubbish_lit : spec_args ) }+ -- Next we want to specialise the 'Eq a' dict away. We need to construct -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details.-specHeader env (bndr : bndrs) (SpecDict d : args)-  | not (isDeadBinder bndr)-  , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)-    -- See Note [Weird special case for SpecDict]-  = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]-       ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d-       ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-             <- specHeader env2 bndrs args-       ; pure ( True      -- Ha!  A useful specialisation!-              , env3-              , leftover_bndrs-              -- See Note [Evidence foralls]-              , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs-              , varToCoreExpr bndr' : rule_es-              , bs'-              , maybeToList dx_bind ++ dx-              , spec_dict : spec_args-              )-       }-   where-     in_scope = Core.getSubstInScope (se_subst env)+specHeader subst (bndr:bndrs) (SpecDict dict_arg : args)+  = do { -- Make up a fresh binder to use in the RULE+         -- It might turn into a dict binding (via bindAuxiliaryDict) which we+         -- then float, so we use cloneIdBndr to get a completely fresh binder+         us <- getUniqueSupplyM+       ; let (subst1, bndr') = Core.cloneIdBndr subst us (zapIdOccInfo bndr)+                 -- zapIdOccInfo: see Note [Zap occ info in rule binders] +         -- Extend the substitution to map bndr :-> dict_arg, for use in the RHS+       ; let (subst2, dx_bind, spec_dict) = bindAuxiliaryDict subst1 bndr bndr' dict_arg++       ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst2 bndrs args++       ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx }+       ; pure ( True, subst3      -- Ha!  A useful specialisation!+              , bndr' : rule_bs, Var bndr' : rule_es+              , spec_bs,    dx', spec_dict : spec_args ) }+ -- Finally, we don't want to specialise on this argument 'i':---   - It's an UnSpecArg, or---   - It's a dead dictionary -- We need to produce a binder, LHS and RHS argument for the RULE, and -- a binder for the specialised body. --@@ -2647,76 +2706,48 @@ -- why 'i' doesn't appear in our RULE above. But we have no guarantee that -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so -- this case must be here.-specHeader env (bndr : bndrs) (_ : args)-    -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead-  = do { -- see Note [Zap occ info in rule binders]-         let (env', bndr') = substBndr env (zapIdOccInfo bndr)-       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-             <- specHeader env' bndrs args--       ; let bndr_ty = idType bndr'--             -- See Note [Drop dead args from specialisations]-             -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let-             (mb_spec_bndr, spec_arg)-                | isDeadBinder bndr-                , Just lit_expr <- mkLitRubbish bndr_ty-                = (Nothing, lit_expr)-                | otherwise-                = (Just bndr', varToCoreExpr bndr')--       ; pure ( useful-              , env''-              , leftover_bndrs-              , bndr' : rule_bs-              , varToCoreExpr bndr' : rule_es-              , case mb_spec_bndr of-                  Just b' -> b' : bs'-                  Nothing -> bs'-              , dx-              , spec_arg : spec_args-              )-       }+specHeader subst (bndr:bndrs) (UnspecArg : args)+  = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr)+                 -- zapIdOccInfo: see Note [Zap occ info in rule binders]+       ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args --- If we run out of binders, stop immediately--- See Note [Specialisation Must Preserve Sharing]-specHeader env [] _ = pure (False, env, [], [], [], [], [], [])+       ; let dummy_arg = varToCoreExpr bndr'+               -- dummy_arg is usually just (Var bndr),+               -- but if bndr :: t1 ~# t2, it'll be (Coercion (CoVar bndr))+               --     or even Coercion Refl (if t1=t2)+               -- See Note [Evidence foralls]+             bndrs = exprFreeIdsList dummy_arg --- Return all remaining binders from the original function. These have the--- invariant that they should all correspond to unspecialised arguments, so--- it's safe to stop processing at this point.-specHeader env bndrs []-  = pure (False, env', bndrs', [], [], [], [], [])-  where-    (env', bndrs') = substBndrs env bndrs+       ; pure ( useful, subst2+              , bndrs ++ rule_bs,     dummy_arg : rule_es+              , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) }   -- | Binds a dictionary argument to a fresh name, to preserve sharing bindAuxiliaryDict-  :: SpecEnv+  :: Subst   -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression-  -> ( SpecEnv        -- Substitutes for orig_dict_id+  -> ( Subst          -- Substitutes for orig_dict_id      , Maybe DictBind -- Auxiliary dict binding, if any      , OutExpr)       -- Witnessing expression (always trivial)-bindAuxiliaryDict env@(SE { se_subst = subst })-                  orig_dict_id fresh_dict_id dict_expr+bindAuxiliaryDict subst orig_dict_id fresh_dict_id dict_arg    -- If the dictionary argument is trivial,   -- don’t bother creating a new dict binding; just substitute-  | exprIsTrivial dict_expr-  = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr }-    in -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $-       (env', Nothing, dict_expr)+  | exprIsTrivial dict_arg+  , let subst' = Core.extendSubst subst orig_dict_id dict_arg+  = -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $+    (subst', Nothing, dict_arg)    | otherwise  -- Non-trivial dictionary arg; make an auxiliary binding-  = let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_expr+  , let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_arg -        dict_bind = mkDB (NonRec fresh_dict_id' dict_expr)-        env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id')-                                `Core.extendSubstInScope` fresh_dict_id' }-                                -- Ensure the new unfolding is in the in-scope set-    in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $-       (env', Just dict_bind, Var fresh_dict_id')+        dict_bind = mkDB (NonRec fresh_dict_id' dict_arg)+        subst'    = Core.extendSubst subst orig_dict_id (Var fresh_dict_id')+                    `Core.extendSubstInScope` fresh_dict_id'+                    -- Ensure the new unfolding is in the in-scope set+  = -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $+    (subst', Just dict_bind, Var fresh_dict_id')  addDictUnfolding :: Id -> CoreExpr -> Id -- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting]@@ -2803,12 +2834,10 @@  Note [Specialising polymorphic dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Note June 2023: This has proved to be quite a tricky optimisation to get right see (#23469, #23109, #21229, #23445) so it is now guarded by a flag `-fpolymorphic-specialisation`. - Consider     class M a where { foo :: a -> Int } @@ -2848,12 +2877,27 @@       function.  (MP3) If we have f :: forall m. Monoid m => blah, and two calls-        (f @(Endo b)      (d :: Monoid (Endo b))-        (f @(Endo (c->c)) (d :: Monoid (Endo (c->c)))+        (f @(Endo b)      (d1 :: Monoid (Endo b))+        (f @(Endo (c->c)) (d2 :: Monoid (Endo (c->c)))       we want to generate a specialisation only for the first.  The second       is just a substitution instance of the first, with no greater specialisation.-      Hence the call to `remove_dups` in `filterCalls`.+      Hence the use of `removeDupCalls` in `filterCalls`. +      You might wonder if `d2` might be more specialised than `d1`; but no.+      This `removeDupCalls` thing is at the definition site of `f`, and both `d1`+      and `d2` are in scope. So `d1` is simply more polymorphic than `d2`, but+      is just as specialised.++      This distinction is sadly lost once we build a RULE, so `alreadyCovered`+      can't be so clever.  E.g if we have an existing RULE+            forall @a (d1:Ord Int) (d2: Eq a). f @a @Int d1 d2 = ...+      and a putative new rule+            forall (d1:Ord Int) (d2: Eq Int). f @Int @Int d1 d2 = ...+      we /don't/ want the existing rule to subsume the new one.++      So we sadly put up with having two rather different places where we+      eliminate duplicates: `alreadyCovered` and `removeDupCalls`.+ All this arose in #13873, in the unexpected form that a SPECIALISE pragma made the program slower!  The reason was that the specialised function $sinsertWith arising from the pragma looked rather like `f`@@ -2950,16 +2994,29 @@   -- The list of types and dictionaries is guaranteed to   -- match the type of f   -- The Bag may contain duplicate calls (i.e. f @T and another f @T)-  -- These dups are eliminated by already_covered in specCalls+  -- These dups are eliminated by alreadyCovered in specCalls  data CallInfo-  = CI { ci_key  :: [SpecArg]   -- All arguments+  = CI { ci_key  :: [SpecArg]   -- Arguments of the call+                                -- See Note [The (CI-KEY) invariant]+        , ci_fvs  :: IdSet       -- Free Ids of the ci_key call                                 -- /not/ including the main id itself, of course                                 -- NB: excluding tyvars:                                 --     See Note [Specialising polymorphic dictionaries]     } +{- Note [The (CI-KEY) invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant (CI-KEY):+   In the `ci_key :: [SpecArg]` field of `CallInfo`,+     * The list is non-empty+     * The least element is always a `SpecDict`++In this way the RULE has as few args as possible, which broadens its+applicability, since rules only fire when saturated.+-}+ type DictExpr = CoreExpr  ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet@@ -3004,22 +3061,16 @@   = MkUD {ud_binds = emptyFDBs,           ud_calls = unitDVarEnv id $ CIS id $                      unitBag (CI { ci_key  = args-                                 , ci_fvs  = call_fvs }) }+                                 , ci_fvs  = fvVarSet call_fvs }) }   where-    call_fvs =-      foldr (unionVarSet . free_var_fn) emptyVarSet args--    free_var_fn =-      if gopt Opt_PolymorphicSpecialisation (se_dflags spec_env)-        then specArgFreeIds-        else specArgFreeVars--+    poly_spec = gopt Opt_PolymorphicSpecialisation (se_dflags spec_env) -        -- specArgFreeIds: we specifically look for free Ids, not TyVars-        --    see (MP1) in Note [Specialising polymorphic dictionaries]-        ---        -- We don't include the 'id' itself.+    -- With -fpolymorphic-specialisation, keep just local /Ids/+    -- Otherwise, keep /all/ free vars including TyVars+    -- See (MP1) in Note [Specialising polymorphic dictionaries]+    -- But NB: we don't include the 'id' itself.+    call_fvs | poly_spec = specArgsFVs isLocalId args+             | otherwise = specArgsFVs isLocalVar args  mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails mkCallUDs env fun args@@ -3048,33 +3099,87 @@     ci_key :: [SpecArg]     ci_key = dropWhileEndLE (not . isSpecDict) $              zipWith mk_spec_arg args pis-             -- Drop trailing args until we get to a SpecDict-             -- In this way the RULE has as few args as possible,-             -- which broadens its applicability, since rules only-             -- fire when saturated+             -- Establish (CI-KEY): drop trailing args until we get to a SpecDict      mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg-    mk_spec_arg arg (Named bndr)+    mk_spec_arg (Type ty) (Named bndr)       |  binderVar bndr `elemVarSet` constrained_tyvars-      = case arg of-          Type ty -> SpecType ty-          _       -> pprPanic "ci_key" $ ppr arg-      |  otherwise = UnspecType+      = SpecType ty+      | otherwise+      = UnspecType+    mk_spec_arg non_type_arg (Named bndr)+      = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr)      -- For "invisibleFunArg", which are the type-class dictionaries,     -- we decide on a case by case basis if we want to specialise     -- on this argument; if so, SpecDict, if not UnspecArg-    mk_spec_arg arg (Anon pred af)+    mk_spec_arg arg (Anon _pred af)       | isInvisibleFunArg af-      , interestingDict arg (scaledThing pred)+      , interestingDict env arg               -- See Note [Interesting dictionary arguments]       = SpecDict arg        | otherwise = UnspecArg -{--Note [Ticks on applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~+wantCallsFor :: SpecEnv -> Id -> Bool+-- See Note [wantCallsFor]+wantCallsFor _env f+  = case idDetails f of+      RecSelId {}      -> False+      DataConWorkId {} -> False+      DataConWrapId {} -> False+      ClassOpId {}     -> False+      PrimOpId {}      -> False+      FCallId {}       -> False+      TickBoxOpId {}   -> False+      CoVarId {}       -> False++      DFunId {}        -> True+      VanillaId {}     -> True+      JoinId {}        -> True+      WorkerLikeId {}  -> True+      RepPolyId {}     -> True++interestingDict :: SpecEnv -> CoreExpr -> Bool+-- This is a subtle and important function+-- See Note [Interesting dictionary arguments]+interestingDict env (Var v)  -- See (ID3) and (ID5)+  | Just rhs <- maybeUnfoldingTemplate (idUnfolding v)+  -- Might fail for loop breaker dicts but that seems fine.+  = interestingDict env rhs++interestingDict env arg  -- Main Plan: use exprIsConApp_maybe+  | Cast inner_arg _ <- arg  -- See (ID5)+  = if | isConstraintKind $ typeKind $ exprType inner_arg+       -- If coercions were always homo-kinded, we'd know+       -- that this would be the only case+       -> interestingDict env inner_arg++       -- Check for an implicit parameter at the top+       | Just (cls,_) <- getClassPredTys_maybe arg_ty+       , isIPClass cls      -- See (ID5)+       -> False++       -- Otherwise we are unwrapping a unary type class+       | otherwise+       -> exprIsHNF arg   -- See (ID7)++  | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg+  , Just cls <- tyConClass_maybe (dataConTyCon data_con)+  , definitely_not_ip_like       -- See (ID4)+  = if null (classMethods cls)   -- See (ID6)+    then any (interestingDict env) args+    else True++  | otherwise+  = not (exprIsTrivial arg) && definitely_not_ip_like  -- See (ID8)+  where+    arg_ty                  = exprType arg+    definitely_not_ip_like  = not (couldBeIPLike arg_ty)+    in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding++{- Note [Ticks on applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ticks such as source location annotations can sometimes make their way onto applications (see e.g. #21697). So if we see something like @@ -3086,51 +3191,128 @@ The resulting RULE also has to be able to match this annotated use site, so we only look through ticks that RULE matching looks through (see Note [Tick annotations in RULE matching] in GHC.Core.Rules).--} -wantCallsFor :: SpecEnv -> Id -> Bool-wantCallsFor _env _f = True- -- We could reduce the size of the UsageDetails by being less eager- -- about collecting calls for LocalIds: there is no point for- -- ones that are lambda-bound.  We can't decide this by looking at- -- the (absence of an) unfolding, because unfoldings for local- -- functions are discarded by cloneBindSM, so no local binder will- -- have an unfolding at this stage.  We'd have to keep a candidate- -- set of let-binders.- --- -- Not many lambda-bound variables have dictionary arguments, so- -- this would make little difference anyway.- --- -- For imported Ids we could check for an unfolding, but we have to- -- do so anyway in canSpecImport, and it seems better to have it- -- all in one place.  So we simply collect usage info for imported- -- overloaded functions.+Note [wantCallsFor]+~~~~~~~~~~~~~~~~~~~+`wantCallsFor env f` says whether the Specialiser should collect calls for+function `f`; other thing being equal, the fewer calls we collect the better. It+is False for things we can't specialise: -{- Note [Interesting dictionary arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* ClassOpId: never inline and we don't have a defn to specialise; we specialise+  them through fireRewriteRules.+* PrimOpId: are never overloaded+* Data constructors: we never specialise them++We could reduce the size of the UsageDetails by being less eager about+collecting calls for some LocalIds: there is no point for ones that are+lambda-bound.  We can't decide this by looking at the (absence of an) unfolding,+because unfoldings for local functions are discarded by cloneBindSM, so no local+binder will have an unfolding at this stage.  We'd have to keep a candidate set+of let-binders.++Not many lambda-bound variables have dictionary arguments, so this would make+little difference anyway.++For imported Ids we could check for an unfolding, but we have to do so anyway in+canSpecImport, and it seems better to have it all in one place.  So we simply+collect usage info for imported overloaded functions.++Note [Interesting dictionary arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this          \a.\d:Eq a.  let f = ... in ...(f d)... There really is not much point in specialising f wrt the dictionary d, because the code for the specialised f is not improved at all, because d is lambda-bound.  We simply get junk specialisations. -What is "interesting"?  Just that it has *some* structure.  But what about-variables?  We look in the variable's /unfolding/.  And that means-that we must be careful to ensure that dictionaries have unfoldings,+What is "interesting"?  Our Main Plan is to use `exprIsConApp_maybe` to see+if the argument is a dictionary constructor applied to some arguments, in which+case we can clearly specialise. But there are wrinkles: -* cloneBndrSM discards non-Stable unfoldings-* specBind updates the unfolding after specialisation-  See Note [Update unfolding after specialisation]-* bindAuxiliaryDict adds an unfolding for an aux dict-  see Note [Specialisation modulo dictionary selectors]-* specCase adds unfoldings for the new bindings it creates+(ID1) Note that we look at the argument /term/, not its /type/.  Suppose the+  argument is+         (% d1, d2 %) |> co+  where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family.+  Then its type (F Int a) looks very un-informative, but the term is super+  helpful.  See #19747 (where missing this point caused a 70x slow down)+  and #7785. -We accidentally lost accurate tracking of local variables for a long-time, because cloned variables didn't have unfoldings. But makes a-massive difference in a few cases, eg #5113. For nofib as a-whole it's only a small win: 2.2% improvement in allocation for ansi,-1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.+(ID2) Note that the Main Plan works fine for an argument that is a DFun call,+   e.g.    $fOrdList $dOrdInt+   because `exprIsConApp_maybe` cleverly deals with DFunId applications.  Good! +(ID3) For variables, we look in the variable's /unfolding/.  And that means+   that we must be careful to ensure that dictionaries /have/ unfoldings:+   * cloneBndrSM discards non-Stable unfoldings+   * specBind updates the unfolding after specialisation+     See Note [Update unfolding after specialisation]+   * bindAuxiliaryDict adds an unfolding for an aux dict+     see Note [Specialisation modulo dictionary selectors]+   * specCase adds unfoldings for the new bindings it creates++   We accidentally lost accurate tracking of local variables for a long+   time, because cloned variables didn't have unfoldings. But makes a+   massive difference in a few cases, eg #5113. For nofib as a+   whole it's only a small win: 2.2% improvement in allocation for ansi,+   1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.++(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains+   an implicit parameter, because implicit parameters are emphatically not singleton+   types.  See #25999:+     useImplicit :: (?i :: Int) => Int+     useImplicit = ?i + 1++     foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit)+   Both calls to `useImplicit` are at type `?i::Int`, but they pass different values.+   We must not specialise on implicit parameters!  Hence the call to `couldBeIPLike`+   in `definitely_not_ip_like`.++(ID5) Suppose the argument is (e |> co).  Can we rely on `exprIsConApp_maybe` to deal+   with the coercion.  No!  That only works if (co :: C t1 ~ C t2) with the same type+   constructor at the top of both sides.  But see the example in (ID1), where that+   is not true.  For the same reason, we can't rely on `exprIsConApp_maybe` to look+   through unfoldings (because there might be a cast inside), hence dealing with+   expandable unfoldings in `interestingDict` directly.++   For the same reasons as in (ID4), we must take care to not allow an implicit+   parameter to sneak through, so we must not unwrap the newtype cast for the+   unary IP class; hence the `isIPClass` call.  (We don't need to call+   `couldBeIPLike`, as implicit parameters hidden behind a type family are+   detected by the recursive call to `interestingDict` on the argument inside the+   cast.)++(ID6) The Main Plan says that it's worth specialising if the argument is an application+   of a dictionary contructor.  But what if the dictionary has no methods?  Then we+   gain nothing by specialising, unless the /superclasses/ are interesting.   A case+   in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class+   with N superclasses and no methods.++(ID7) A unary (single-method) class is currently represented by (meth |> co).  We+   will unwrap the cast (see (ID5)) and then want to reply "yes" if the method+   has any struture.  We rather arbitrarily use `exprIsHNF` for this.  (We plan a+   new story for unary classes, see #23109, and this special case will become+   irrelevant.)++(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a+   non-trivial argument as interesting. In T19695 we have this:+      askParams :: Monad m => blah+      mhelper   :: MonadIO m => blah+      mhelper (d:MonadIO m) = ...(askParams @m ($p1 d))....+   where `$p1` is the superclass selector for `MonadIO`.  Now, if `mhelper` is+   specialised at `Handler` we'll get this call in the specialised `$smhelper`:+            askParams @Handler ($p1 $fMonadIOHandler)+   and we /definitely/ want to specialise that, even though the argument isn't+   visibly a dictionary application.  In fact the specialiser fires the superclass+   selector rule (see Note [Fire rules in the specialiser]), so we get+            askParams @Handler ($cp1MonadIO $fMonadIOIO)+   but it /still/ doesn't look like a dictionary application.++   Conclusion: we optimistically assume that any non-trivial argument is worth+   specialising on.++   So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look+   under type-family casts (ID1) and constraint tuples (ID6).+ Note [Update unfolding after specialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#21848)@@ -3157,12 +3339,13 @@ Now `f` turns into:    f @a @b (dd :: D a) (ds :: Show b) a b+      = let dc :: D a = %p1 dd  -- Superclass selection        in meth @a dc ....           meth @a dc ....  When we specialise `f`, at a=Int say, that superclass selection can-nfire (via rewiteClassOps), but that info (that 'dc' is now a+fire (via rewiteClassOps), but that info (that 'dc' is now a particular dictionary `C`, of type `C Int`) must be available to the call `meth @a dc`, so that we can fire the `meth` class-op, and thence specialise `wombat`.@@ -3172,27 +3355,6 @@ the Rec case.) -} -interestingDict :: CoreExpr -> Type -> Bool--- A dictionary argument is interesting if it has *some* structure,--- see Note [Interesting dictionary arguments]--- NB: "dictionary" arguments include constraints of all sorts,---     including equality constraints; hence the Coercion case--- To make this work, we need to ensure that dictionaries have--- unfoldings in them.-interestingDict arg arg_ty-  | not (typeDeterminesValue arg_ty) = False   -- See Note [Type determines value]-  | otherwise                        = go arg-  where-    go (Var v)               =  hasSomeUnfolding (idUnfolding v)-                             || isDataConWorkId v-    go (Type _)              = False-    go (Coercion _)          = False-    go (App fn (Type _))     = go fn-    go (App fn (Coercion _)) = go fn-    go (Tick _ a)            = go a-    go (Cast e _)            = go e-    go _                     = True- thenUDs :: UsageDetails -> UsageDetails -> UsageDetails thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})         (MkUD {ud_binds = db2, ud_calls = calls2})@@ -3289,7 +3451,11 @@ -- Used at a lambda or case binder; just dump anything mentioning the binder dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })   | null bndrs = (uds, nilOL)  -- Common in case alternatives-  | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $+  | otherwise  = -- pprTrace "dumpUDs" (vcat+                 --    [ text "bndrs" <+> ppr bndrs+                 --    , text "uds" <+> ppr uds+                 --    , text "free_uds" <+> ppr free_uds+                 --    , text "dump-dbs" <+> ppr dump_dbs ]) $                  (free_uds, dump_dbs)   where     free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls }@@ -3328,20 +3494,17 @@     calls_for_me = case lookupDVarEnv orig_calls fn of                         Nothing -> []                         Just cis -> filterCalls cis orig_dbs-         -- filterCalls: drop calls that (directly or indirectly)-         -- refer to fn.  See Note [Avoiding loops (DFuns)]  ---------------------- filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]--- Remove dominated calls (Note [Specialising polymorphic dictionaries])--- and loopy DFuns (Note [Avoiding loops (DFuns)])+-- Remove+--   (a) dominated calls: (MP3) in Note [Specialising polymorphic dictionaries]+--   (b) loopy DFuns: Note [Avoiding loops (DFuns)] filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })-  | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns-  = filter ok_call de_dupd_calls-  | otherwise         -- Do not apply it to non-DFuns-  = de_dupd_calls  -- See Note [Avoiding loops (non-DFuns)]+  | isDFunId fn  = filter ok_call de_dupd_calls  -- Deals with (b)+  | otherwise    = de_dupd_calls   where-    de_dupd_calls = remove_dups call_bag+    de_dupd_calls = removeDupCalls call_bag -- Deals with (a)      dump_set = foldl' go (unitVarSet fn) dbs       -- This dump-set could also be computed by splitDictBinds@@ -3355,10 +3518,10 @@      ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set -remove_dups :: Bag CallInfo -> [CallInfo]+removeDupCalls :: Bag CallInfo -> [CallInfo] -- Calls involving more generic instances beat more specific ones. -- See (MP3) in Note [Specialising polymorphic dictionaries]-remove_dups calls = foldr add [] calls+removeDupCalls calls = foldr add [] calls   where     add :: CallInfo -> [CallInfo] -> [CallInfo]     add ci [] = [ci]@@ -3367,16 +3530,24 @@                       | otherwise               = ci2 : add ci1 cis  beats_or_same :: CallInfo -> CallInfo -> Bool+-- (beats_or_same ci1 ci2) is True if specialising on ci1 subsumes ci2+-- That is: ci1's types are less specialised than ci2+--          ci1   specialises on the same dict args as ci2 beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })   = go args1 args2   where-    go [] _ = True+    go []           []           = True     go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2-    go (_:_)        []           = False +    -- If one or the other runs dry, the other must still have a SpecDict+    -- because of the (CI-KEY) invariant.  So neither subsumes the other;+    -- one is more specialised (faster code) but the other is more generally+    -- applicable.+    go  _ _ = False+     go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)-    go_arg UnspecType     UnspecType     = True     go_arg (SpecDict {})  (SpecDict {})  = True+    go_arg UnspecType     UnspecType     = True     go_arg UnspecArg      UnspecArg      = True     go_arg _              _              = False @@ -3444,9 +3615,9 @@                               (ys, uds2) <- mapAndCombineSM f xs                               return (y:ys, uds1 `thenUDs` uds2) -extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv-extendTvSubst env tv ty-  = env { se_subst = Core.extendTvSubst (se_subst env) tv ty }+-- extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv+-- extendTvSubst env tv ty+--   = env { se_subst = Core.extendTvSubst (se_subst env) tv ty }  extendInScope :: SpecEnv -> OutId -> SpecEnv extendInScope env@(SE { se_subst = subst }) bndr@@ -3466,7 +3637,7 @@ substBndr env bs = case Core.substBndr (se_subst env) bs of                       (subst', bs') -> (env { se_subst = subst' }, bs') -substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])+substBndrs :: Traversable f => SpecEnv -> f CoreBndr -> (SpecEnv, f CoreBndr) substBndrs env bs = case Core.substBndrs (se_subst env) bs of                       (subst', bs') -> (env { se_subst = subst' }, bs') @@ -3481,20 +3652,9 @@  cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id]) cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs-  = do { (subst', bndrs') <- Core.cloneRecIdBndrs subst bndrs+  = do { (subst', bndrs') <- Core.cloneRecIdBndrsM subst bndrs        ; let env' = env { se_subst = subst' }        ; return (env', bndrs') }--newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr)--- Make up completely fresh binders for the dictionaries--- Their bindings are going to float outwards-newDictBndr env@(SE { se_subst = subst }) b-  = do { uniq <- getUniqueM-       ; let n    = idName b-             ty'  = substTyUnchecked subst (idType b)-             b'   = mkUserLocal (nameOccName n) uniq ManyTy ty' (getSrcSpan n)-             env' = env { se_subst = subst `Core.extendSubstInScope` b' }-       ; pure (env', b') }  newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id     -- Give the new Id a similar occurrence name to the old one
compiler/GHC/Core/Opt/StaticArgs.hs view
@@ -111,7 +111,7 @@     let (binders, rhss) = unzip pairs     rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss     let (rhss', sat_info_rhss') = unzip rhss_SATed-    return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')+    return (Rec (zipEqual binders rhss'), mergeIdSATInfos sat_info_rhss')  data App = VarApp Id | TypeApp Type | CoApp Coercion data Staticness a = Static a | NotStatic
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -16,6 +16,7 @@    , mkAbsentFiller    , isWorkerSmallEnough, dubiousDataConInstArgTys    , boringSplit, usefulSplit, workWrapArity+   , canUnboxType, canUnboxTyCon    ) where @@ -32,6 +33,7 @@ import GHC.Core.Predicate( isDictTy ) import GHC.Core.Reduction import GHC.Core.FamInstEnv+import GHC.Core.Predicate( isEqualityClass ) import GHC.Core.TyCon import GHC.Core.TyCon.Set import GHC.Core.TyCon.RecWalk@@ -218,7 +220,7 @@         ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars)               empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs)               zapped_arg_vars = map zap_var arg_vars-        ; (subst, cloned_arg_vars) <- cloneBndrs empty_subst zapped_arg_vars+        ; (subst, cloned_arg_vars) <- cloneBndrsM empty_subst zapped_arg_vars         ; let res_ty' = substTyUnchecked subst res_ty               init_str_marks = map (const NotMarkedStrict) cloned_arg_vars @@ -611,7 +613,7 @@ -- 's' will be 'Demand' or 'Cpr'. data DataConPatContext s   = DataConPatContext-  { dcpc_dc      :: !DataCon+  { dcpc_dc      :: !DataCon  -- INVARIANT: canUnboxTyCon is true of this DataCon's tycon   , dcpc_tc_args :: ![Type]   , dcpc_co      :: !Coercion   , dcpc_args    :: ![s]@@ -664,7 +666,7 @@    -- From here we are strict and not absent   | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty-  , Just dc <- tyConSingleAlgDataCon_maybe tc+  , Just [dc] <- canUnboxTyCon tc  -- tc is never a newtype   , let arity = dataConRepArity dc   , Just (Unboxed, dmds) <- viewProd arity sd -- See Note [Boxity analysis]   , dmds `lengthIs` dataConRepArity dc@@ -682,7 +684,7 @@ canUnboxResult fam_envs ty cpr   | Just (con_tag, arg_cprs) <- asConCpr cpr   , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty-  , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning+  , Just dcs <- canUnboxTyCon tc <|> open_body_ty_warning   , dcs `lengthAtLeast` con_tag -- This might not be true if we import the                                 -- type constructor via a .hs-boot file (#8743)   , let dc = dcs `getNth` (con_tag - fIRST_TAG)@@ -702,8 +704,101 @@     -- See Note [non-algebraic or open body type warning]     open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing -{- Note [Which types are unboxed?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+++canUnboxType :: HasDebugCallStack => Type -> Maybe [DataCon]+canUnboxType arg_ty = case tyConAppTyCon_maybe arg_ty of+                        Just tc -> canUnboxTyCon tc+                        Nothing -> Nothing++canUnboxTyCon :: HasDebugCallStack => TyCon -> Maybe [DataCon]+-- True for+--   boxed algebraic datatypes+--   unboxed tuples and sums+--+-- False for+--   class dictionaries, except equality classes and tuples+--               See Note [Do not unbox class dictionaries]+--+-- Precondition: tc is not a newtype+canUnboxTyCon tc+  | Just cls <- tyConClass_maybe tc+  , not (isEqualityClass cls)+  = Nothing     -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries]++  | otherwise+  = assertPpr (not (isNewTyCon tc)) (ppr tc) $  -- Check precondition+    tyConDataCons_maybe tc++{- Note [Do not unbox class dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We never unbox class dictionaries in worker/wrapper.++1. INLINABLE functions+   If we have+      f :: Ord a => [a] -> Int -> a+      {-# INLINABLE f #-}+   and we worker/wrapper f, we'll get a worker with an INLINABLE pragma+   (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),+   which can still be specialised by the type-class specialiser, something like+      fw :: Ord a => [a] -> Int# -> a++   BUT if f is strict in the Ord dictionary, we might unpack it, to get+      fw :: (a->a->Bool) -> [a] -> Int# -> a+   and the type-class specialiser can't specialise that. An example is #6056.++   Historical note: #14955 describes how I got this fix wrong the first time.+   I got aware of the issue in T5075 by the change in boxity of loop between+   demand analysis runs.++2. -fspecialise-aggressively.  As #21286 shows, the same phenomenon can occur+   occur without INLINABLE, when we use -fexpose-all-unfoldings and+   -fspecialise-aggressively to do vigorous cross-module specialisation.++3. #18421 found that unboxing a dictionary can also make the worker less likely+   to inline; the inlining heuristics seem to prefer to inline a function+   applied to a dictionary over a function applied to a bunch of functions.++TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing+a raft of higher-order functions isn't a huge win anyway -- you really want to+specialise the function.++Wrinkle (DNB1): we /do not/ to unbox tuple dictionaries either.  We used to+  have a special case to unbox tuple dictionaries (#23398), but it ultimately+  turned out to be a very bad idea (see !19747#note_626297).   In summary:++  - If w/w unboxes tuple dictionaries we get things like+         case d of CTuple2 d1 d2 -> blah+    rather than+         let { d1 = sc_sel1 d; d2 = sc_sel2 d } in blah+    The latter works much better with the specialiser: when `d` is instantiated+    to some useful dictionary the `sc_sel1 d` selection can fire.++   - The attempt to deal with unpacking dictionaries with `case` led to+     significant extra complexity in the type-class specialiser (#26158) that is+     rendered unnecessary if we only take do superclass selection with superclass+     selectors, never with `case` expressions.++     Even with that extra complexity, specialisation was /still/ sometimes worse,+     and sometimes /tremendously/ worse (a factor of 70x); see #19747.++   - Suppose f :: forall a. (% Eq a, Show a %) => blah+     The specialiser is perfectly capable of specialising a call like+             f @Int (% dEqInt, dShowInt %)+     so the tuple doesn't get in the way.++   - It's simpler and more uniform.  There is nothing special about constraint+     tuples; anyone can write   class (C1 a, C2 a) => D a  where {}++Wrinkle (DNB2): we /do/ want to unbox equality dictionaries,+  for (~), (~~), and Coercible (#23398).  Their payload is a single unboxed+  coercion.  We never want to specialise on `(t1 ~ t2)`.  All that would do is+  to make a copy of the function's RHS with a particular coercion.  Unlike+  normal class methods, that does not unlock any new optimisation+  opportunities in the specialised RHS.++Note [Which types are unboxed?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Worker/wrapper will unbox    1. A strict data type argument, that@@ -835,7 +930,7 @@ before calling the partially applied function. But this would be neither a small nor simple change so we stick with A) and a flag for B) for now. -See also Note [Tag Inference] and Note [CBV Function Ids]+See also Note [EPT enforcement] and Note [CBV Function Ids]  Note [Worker/wrapper for strict arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -861,7 +956,7 @@  The worker `$wf` is a CBV function (see `Note [CBV Function Ids]` in GHC.Types.Id.Info) and the code generator guarantees that every-call to `$wf` has a properly tagged argument (see `GHC.Stg.InferTags.Rewrite`).+call to `$wf` has a properly tagged argument (see `GHC.Stg.EnforceEpt.Rewrite`).  Is this a win?  Not always: * It can cause slight codesize increases. This is since we push evals to every@@ -984,7 +1079,7 @@              -- don't end up in lambda binders of the worker.              -- See Note [Never put `OtherCon` unfoldings on lambda binders]              arg_ids' = map zapIdUnfolding $-                        zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds+                        zipWithEqual setIdDemandInfo arg_ids ds               unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var)                                      dc (ex_tvs' ++ arg_ids')@@ -1352,7 +1447,8 @@        | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args        = go rec_tc rhs -       | Just con <- tyConSingleAlgDataCon_maybe tc+       | not (isNewTyCon tc)+       , Just con <- tyConSingleDataCon_maybe tc        , Just rec_tc <- if isTupleTyCon tc                         then Just rec_tc                         else checkRecTc rec_tc tc
compiler/GHC/CoreToStg.hs view
@@ -221,6 +221,22 @@ -- (For the gory details, see also the (unpublished) paper, “Practical -- aspects of evidence-based compilation in System FC.”) +-- Note [Saturation of data constructors in STG]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We guarantee that `StgConApp` is an exactly-saturated application of a data+-- constructor worker.+--+-- * If the data constructor is /under/-saturated we just fall through to build+--   a `StgApp`.  Remember, data constructor workers have a regular top-level definition+--   (injected by GHC.CoreToStg.Prep.mkDataConWorkers) so we can partially apply+--   that function.+--+-- * If the data constructor is /over/-saturated, which can happen (see #23865) we again+--   fall through to `StgApp`.  That will fail horribly at runtime (by applying data+--   constructor to an argument) but it should be in dead code, and at least the compiler+--   itself won't crash.  (We could inject an error-thunk instead.)++ -- -------------------------------------------------------------- -- Setting variable info: top-level, binds, RHSs -- --------------------------------------------------------------@@ -388,24 +404,25 @@ -- CorePrep should have converted them all to a real core representation. coreToStgExpr (Lit (LitNumber LitNumBigNat _))  = panic "coreToStgExpr: LitNumBigNat" coreToStgExpr (Lit l)                           = return (StgLit l)-coreToStgExpr (Var v) = coreToStgApp v [] []+coreToStgExpr (Var v) = coreToStgApp v [] [] (idType v) coreToStgExpr (Coercion _)   -- See Note [Coercion tokens]-  = coreToStgApp coercionTokenId [] []+  = coreToStgApp coercionTokenId [] [] (idType coercionTokenId)  coreToStgExpr expr@(App _ _)   = case app_head of-      Var f -> coreToStgApp f args ticks -- Regular application-      Lit l | isLitRubbish l             -- If there is LitRubbish at the head,-                                         --    discard the arguments-                                         --    Recompute representation, because in-                                         --    '(RUBBISH[rep] x) :: (T :: TYPE rep2)'-                                         --    rep might not be equal to rep2-            -> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep (exprType expr))+      Var f -> coreToStgApp f args ticks res_ty -- Regular application+      Lit l | isLitRubbish l  -- Discard arguments if head is LitRubbish+                              -- Recompute representation, because in+                              -- '(RUBBISH[rep] x) :: (T :: TYPE rep2)'+                              -- rep might not be equal to rep2+            -> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep res_ty)        _     -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)     where-      (app_head, args, ticks) = myCollectArgs expr+      res_ty                  = exprType expr+      (app_head, args, ticks) = myCollectArgs expr res_ty+ coreToStgExpr expr@(Lam _ _)   = let         (args, body) = myCollectBinders expr@@ -508,58 +525,61 @@  coreToStgApp :: Id            -- Function              -> [CoreArg]     -- Arguments-             -> [CoreTickish] -- Debug ticks+             -> [StgTickish]  -- From the application nodes+             -> Type          -- Type of the whole application              -> CtsM StgExpr-coreToStgApp f args ticks = do-    (args', ticks') <- coreToStgArgs args-    how_bound <- lookupVarCts f--    let-        n_val_args       = valArgCount args--        -- Mostly, the arity info of a function is in the fn's IdInfo-        -- But new bindings introduced by CoreSat may not have no-        -- arity info; it would do us no good anyway.  For example:-        --      let f = \ab -> e in f-        -- No point in having correct arity info for f!-        -- Hence the hasArity stuff below.-        -- NB: f_arity is only consulted for LetBound things-        f_arity   = stgArity f how_bound-        saturated = f_arity <= n_val_args+coreToStgApp f core_args app_ticks res_ty+  = do { how_bound             <- lookupVarCts f+       ; (stg_args, arg_ticks) <- coreToStgArgs core_args+       ; let app = mkStgApp f how_bound core_args stg_args res_ty+             all_ticks =  app_ticks ++ arg_ticks -        res_ty = exprType (mkApps (Var f) args)-        app = case idDetails f of-                DataConWorkId dc-                  | saturated    -> if isUnboxedSumDataCon dc then-                                      StgConApp dc NoNumber args' (sumPrimReps args)-                                    else-                                      StgConApp dc NoNumber args' []+       -- Forcing these fixes a leak in the code generator,+       -- noticed while profiling for #4367+       ; app `seq` return (foldr add_tick app all_ticks)}+  where+    add_tick !t !e = StgTick t e -                -- 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 _    -> -- assertPpr saturated (ppr f <+> ppr args) $-                                    StgOpApp (StgPrimOp op) args' res_ty+mkStgApp :: Id -> HowBound -> [CoreArg] -> [StgArg] -> Type -> StgExpr+mkStgApp f how_bound core_args stg_args res_ty+  = case idDetails f of+      DataConWorkId dc+        | exactly_saturated  -- See Note [Saturation of data constructors in STG]+        -> if isUnboxedSumDataCon dc then+              StgConApp dc NoNumber stg_args (sumPrimReps core_args)+           else+              StgConApp dc NoNumber stg_args [] -                -- A call to some primitive Cmm function.-                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)-                                          PrimCallConv _))-                                 -> assert saturated $-                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty+      -- 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 _    -> -- assertPpr saturated (ppr f <+> ppr stg_args) $+                          StgOpApp (StgPrimOp op) stg_args res_ty -                -- A regular foreign call.-                FCallId call     -> assert saturated $-                                    StgOpApp (StgFCallOp call (idType f)) args' res_ty+      -- A call to some primitive Cmm function.+      FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)+                                PrimCallConv _))+                       -> assert exactly_saturated $+                          StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) stg_args res_ty -                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')-                _other           -> StgApp f args'+      -- A regular foreign call.+      FCallId call     -> assert exactly_saturated $+                          StgOpApp (StgFCallOp call (idType f)) stg_args res_ty -        add_tick !t !e = StgTick t e-        tapp = foldr add_tick app (map (coreToStgTick res_ty) ticks ++ ticks')+      TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,stg_args) -    -- Forcing these fixes a leak in the code generator, noticed while-    -- profiling for #4367-    app `seq` return tapp+      _other           -> StgApp f stg_args+  where+    -- Mostly, the arity info of a function is in the fn's IdInfo+    -- But new bindings introduced by CoreSat may not have no+    -- arity info; it would do us no good anyway.  For example:+    --      let f = \ab -> e in f+    -- No point in having correct arity info for f!+    -- Hence the hasArity stuff below.+    -- NB: f_arity is only consulted for LetBound things+    f_arity    = stgArity f how_bound+    n_val_args = length stg_args  -- StgArgs are all value arguments+    exactly_saturated  = f_arity == n_val_args   -- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's@@ -624,10 +644,10 @@ coreToStgTick :: Type -- type of the ticked expression               -> CoreTickish               -> StgTickish-coreToStgTick _ty (HpcTick m i)                = HpcTick m i-coreToStgTick _ty (SourceNote span nm)         = SourceNote span nm-coreToStgTick _ty (ProfNote cc cnt scope)      = ProfNote cc cnt scope-coreToStgTick !ty (Breakpoint _ bid fvs modl)  = Breakpoint ty bid fvs modl+coreToStgTick _ty (HpcTick m i)           = HpcTick m i+coreToStgTick _ty (SourceNote span nm)    = SourceNote span nm+coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope+coreToStgTick !ty (Breakpoint _ bid fvs)  = Breakpoint ty bid fvs  -- --------------------------------------------------------------------------- -- The magic for lets:@@ -809,17 +829,28 @@ -- INVARIANT: If the app head is trivial, return the atomic Var/Lit that was -- wrapped in casts, empty case, ticks, etc. -- So keep in sync with 'exprIsTrivial'.-myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])-myCollectArgs expr+myCollectArgs :: HasDebugCallStack+              => CoreExpr -> Type -> (CoreExpr, [CoreArg], [StgTickish])+myCollectArgs expr res_ty   = go expr [] []   where-    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 = 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 h@(Var f) as ts+      | isUnaryClassId f, (the_arg:as') <- dropWhile isTypeArg as+      = go the_arg as' ts+        -- See (UCM1) in Note [Unary class magic] in GHC.Core.TyCon+        -- isUnaryClassId includes both the class op and the data-con++      | otherwise+      = (h, as, ts)++    go (App f a)  as ts = go f (a:as) ts+    go (Cast e _) as ts = go e as 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]+                          -- ticks can appear in type apps+                          go e as (coreToStgTick res_ty t : ts)+     go (Case e b _ alts) as ts  -- Just like in exprIsTrivial!                                 -- Otherwise we fall over in case we encounter                                 -- `(case f a of {}) b` in the future.@@ -828,9 +859,12 @@                    go e [] ts -- NB: Empty case discards arguments        | Just rhs <- isUnsafeEqualityCase e b alts        = go rhs as ts         -- Discards unsafeCoerce in App heads-    go (Lam b e)        as ts-       | isTyVar b            = go e (drop 1 as) ts -- Note [Collect args]-    go e                as ts = (e, as, ts)++    go (Lam b e) as ts+       | isTyVar b+       = go e (drop 1 as) ts -- Note [Collect args]++    go e as ts = (e, as, ts)  {- Note [Collect args] ~~~~~~~~~~~~~~~~~~~~~~
+ compiler/GHC/CoreToStg/AddImplicitBinds.hs view
@@ -0,0 +1,151 @@+{-+(c) The University of Glasgow, 1994-2006++Add implicit bindings+-}++module GHC.CoreToStg.AddImplicitBinds ( addImplicitBinds ) where++import GHC.Prelude++import GHC.CoreToStg.Prep( CorePrepPgmConfig(..) )++import GHC.Unit( ModLocation(..) )++import GHC.Core+import GHC.Core.DataCon( DataCon, dataConWorkId, dataConWrapId )+import GHC.Core.TyCon( TyCon, tyConDataCons, isBoxedDataTyCon, tyConClass_maybe )+import GHC.Core.Class( classAllSelIds )++import GHC.Types.Name+import GHC.Types.Tickish( GenTickish( SourceNote ) )+import GHC.Types.Id( dataConWrapUnfolding_maybe )+import GHC.Types.Id.Make( mkDictSelRhs )+import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )++import GHC.Utils.Outputable+import GHC.Data.FastString+++{- *********************************************************************+*                                                                      *+        Implicit bindings+*                                                                      *+********************************************************************* -}++{- Note [Injecting implicit bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`addImplicitBinds` injects the so-called "implicit bindings" generated by+the TyCons of the module. Specifically:++ * Data constructor wrappers+ * Data constructor workers: see Note [Data constructor workers]+ * Class op selectors: we want curriedn versions of these too++Note that /record selector/ are injected much earlier, at the beginning+of the pipeline -- see Note [Record selectors] in GHC.Tc.TyCl.Utils.++At one time I tried injecting the implicit bindings *early*, at the+beginning of SimplCore.  But that gave rise to real difficulty,+because GlobalIds are supposed to have *fixed* IdInfo, but the+simplifier and other core-to-core passes mess with IdInfo all the+time.  The straw that broke the camels back was when a class selector+got the wrong arity -- ie the simplifier gave it arity 2, whereas+importing modules were expecting it to have arity 1 (#2844).+It's much safer just to inject them right at the end, after tidying.++Oh: two other reasons for injecting them late:++  - If implicit Ids are already in the bindings when we start tidying,+    we'd have to be careful not to treat them as external Ids (in+    the sense of chooseExternalIds); else the Ids mentioned in *their*+    RHSs will be treated as external and you get an interface file+    saying      a18 = <blah>+    but nothing referring to a18 (because the implicit Id is the+    one that does, and implicit Ids don't appear in interface files).++  - More seriously, the tidied type-envt will include the implicit+    Id replete with a18 in its unfolding; but we won't take account+    of a18 when computing a fingerprint for the class; result chaos.++Note [Data constructor workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Create any necessary "implicit" bindings for data con workers.  We+create the rather strange (non-recursive!) binding++        $wC = \x y -> $wC x y++i.e. a curried constructor that allocates.  This means that we can+treat the worker for a constructor like any other function in the rest+of the compiler.  The point here is that CoreToStg will generate a+StgConApp for the RHS, rather than a call to the worker (which would+give a loop).  As Lennart says: the ice is thin here, but it works.++Hmm.  Should we create bindings for dictionary constructors?  They are+always fully applied, and the bindings are just there to support+partial applications. But it's easier to let them through.+-}+++addImplicitBinds :: CorePrepPgmConfig -> ModLocation+                 -> [TyCon] -> CoreProgram -> IO CoreProgram+addImplicitBinds pgm_cfg mod_loc tycons binds+  = return (implicit_binds ++ binds)+  where+    gen_debug_info = cpPgm_generateDebugInfo pgm_cfg+    implicit_binds = concatMap (mkImplicitBinds gen_debug_info mod_loc) tycons+++mkImplicitBinds :: Bool -> ModLocation -> TyCon -> [CoreBind]+-- See Note [Data constructor workers]+-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy+mkImplicitBinds gen_debug_info mod_loc tycon+  = classop_binds ++ datacon_binds+  where+    datacon_binds+      | isBoxedDataTyCon tycon+      = concatMap (dataConBinds gen_debug_info mod_loc) (tyConDataCons tycon)+      | otherwise+      = []+      -- The 'otherwise' includes family TyCons of course, but also (less obviously)+      --  * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make+      --  * type data: we don't want any code for type-only stuff (#24620)++    classop_binds+      | Just cls <- tyConClass_maybe tycon+      = [ NonRec op (mkDictSelRhs cls val_index)+        | (op, val_index) <- classAllSelIds cls `zip` [0..] ]+     | otherwise+     = []++dataConBinds :: Bool -> ModLocation -> DataCon -> [CoreBind]+dataConBinds gen_debug_info mod_loc data_con+  = wrapper_bind ++ worker_bind+  where+    work_id = dataConWorkId data_con+    wrap_id = dataConWrapId data_con+    worker_bind  = [NonRec work_id (add_tick (Var work_id))]+      -- worker_bind: the ice is thin here, but it works:+      --              CorePrep will eta-expand it+    wrapper_bind = case dataConWrapUnfolding_maybe wrap_id of+                     Nothing  -> []+                     Just rhs -> [NonRec wrap_id rhs]+    add_tick = tick_it gen_debug_info mod_loc (getName data_con)++tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr+-- If we want to generate debug info, we put a source note on the+-- worker. This is useful, especially for heap profiling.+tick_it generate_debug_info mod_loc name+  | not generate_debug_info               = id+  | RealSrcSpan span _ <- nameSrcSpan name = tick span+  | Just file <- ml_hs_file mod_loc       = tick (span1 file)+  | otherwise                             = tick (span1 "???")+  where+    tick span  = Tick $ SourceNote span $+                 LexicalFastString $ mkFastString $+                 renderWithContext defaultSDocContext $ ppr name+    span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1++++
compiler/GHC/CoreToStg/Prep.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- {- (c) The University of Glasgow, 1994-2006 @@ -61,8 +59,8 @@ import GHC.Types.Id.Info import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Types.Basic-import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )-import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )+import GHC.Types.Name   ( OccName, NamedThing(..), isInternalName )+import GHC.Types.Name.Occurrence (occNameString) import GHC.Types.Literal import GHC.Types.Tickish import GHC.Types.Unique.Supply@@ -72,6 +70,7 @@ import Data.ByteString.Builder.Prim  import Control.Monad+import Data.List (intercalate)  {- Note [CorePrep Overview]@@ -108,23 +107,17 @@ 7.  Give each dynamic CCall occurrence a fresh unique; this is     rather like the cloning step above. -8.  Inject bindings for the "implicit" Ids:-        * Constructor wrappers-        * Constructor workers-    We want curried definitions for all of these in case they-    aren't inlined by some caller.-- 9. Convert bignum literals into their core representation.+8. Convert bignum literals into their core representation. -10. Uphold tick consistency while doing this: We move ticks out of+9. Uphold tick consistency while doing this: We move ticks out of     (non-type) applications where we can, and make sure that we     annotate according to scoping rules when floating. -11. Collect cost centres (including cost centres in unfoldings) if we're in+10. Collect cost centres (including cost centres in unfoldings) if we're in     profiling mode. We have to do this here because we won't have unfoldings     after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules]. -12. Eliminate some magic Ids, specifically+11. Eliminate some magic Ids, specifically      runRW# (\s. e)  ==>  e[readWorldId/s]              lazy e  ==>  e (see Note [lazyId magic] in GHC.Types.Id.Make)          noinline e  ==>  e@@ -242,30 +235,24 @@ corePrepPgm :: Logger             -> CorePrepConfig             -> CorePrepPgmConfig-            -> Module -> ModLocation -> CoreProgram -> [TyCon]+            -> Module -> CoreProgram             -> IO CoreProgram corePrepPgm logger cp_cfg pgm_cfg-            this_mod mod_loc binds data_tycons =+            this_mod binds =     withTiming logger                (text "CorePrep"<+>brackets (ppr this_mod))                (\a -> a `seqList` ()) $ do-    us <- mkSplitUniqSupply 's'     let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg +    us <- mkSplitUniqSupply 's'     let-        implicit_binds = mkDataConWorkers-          (cpPgm_generateDebugInfo pgm_cfg)-          mod_loc data_tycons-            -- NB: we must feed mkImplicitBinds through corePrep too-            -- so that they are suitably cloned and eta-expanded--        binds_out = initUs_ us $ do-                      floats1 <- corePrepTopBinds initialCorePrepEnv binds-                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds-                      return (deFloatTop (floats1 `zipFloats` floats2))+        floats = initUs_ us $+                 corePrepTopBinds initialCorePrepEnv binds+        binds_out = deFloatTop floats      endPassIO logger (cpPgm_endPassConfig pgm_cfg)               binds_out []+     return binds_out  corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr@@ -291,27 +278,11 @@                                floatss <- go env' binds                                return (floats `zipFloats` floatss) -mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> [CoreBind]--- See Note [Data constructor workers]--- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy-mkDataConWorkers generate_debug_info mod_loc data_tycons-  = [ NonRec id (tick_it (getName data_con) (Var id))-                                -- The ice is thin here, but it works-    | tycon <- data_tycons,     -- CorePrep will eta-expand it-      data_con <- tyConDataCons tycon,-      let id = dataConWorkId data_con-    ]- where-   -- If we want to generate debug info, we put a source note on the-   -- worker. This is useful, especially for heap profiling.-   tick_it name-     | not generate_debug_info               = id-     | RealSrcSpan span _ <- nameSrcSpan name = tick span-     | Just file <- ml_hs_file mod_loc       = tick (span1 file)-     | otherwise                             = tick (span1 "???")-     where tick span  = Tick $ SourceNote span $-             LexicalFastString $ mkFastString $ renderWithContext defaultSDocContext $ ppr name-           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1+{- *********************************************************************+*                                                                      *+                The main code+*                                                                      *+********************************************************************* -}  {- Note [Floating in CorePrep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -394,24 +365,6 @@ join points from nullary join points, but there's no clear benefit at this stage. -Note [Data constructor workers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Create any necessary "implicit" bindings for data con workers.  We-create the rather strange (non-recursive!) binding--        $wC = \x y -> $wC x y--i.e. a curried constructor that allocates.  This means that we can-treat the worker for a constructor like any other function in the rest-of the compiler.  The point here is that CoreToStg will generate a-StgConApp for the RHS, rather than a call to the worker (which would-give a loop).  As Lennart says: the ice is thin here, but it works.--Hmm.  Should we create bindings for dictionary constructors?  They are-always fully applied, and the bindings are just there to support-partial applications. But it's easier to let them through.-- Note [Dead code in CorePrep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Imagine that we got an input program like this (see #4962):@@ -614,12 +567,6 @@  - #14375  - #15260  - #18061--************************************************************************-*                                                                      *-                The main code-*                                                                      *-************************************************************************ -}  cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind@@ -630,11 +577,10 @@ cpeBind top_lvl env (NonRec bndr rhs)   | not (isJoinId bndr)   = do { (env1, bndr1) <- cpCloneBndr env bndr-       ; let dmd         = idDemandInfo bndr-             is_unlifted = isUnliftedType (idType bndr)+       ; let dmd = idDemandInfo bndr+             lev = typeLevity (idType bndr)        ; (floats, rhs1) <- cpePair top_lvl NonRecursive-                                   dmd is_unlifted-                                   env bndr1 rhs+                                   dmd lev env bndr1 rhs        -- See Note [Inlining in CorePrep]        ; let triv_rhs = exprIsTrivial rhs1              env2    | triv_rhs  = extendCorePrepEnvExpr env1 bndr rhs1@@ -644,7 +590,7 @@                      | otherwise                      = snocFloat floats new_float -             new_float = mkNonRecFloat env is_unlifted bndr1 rhs1+             (new_float, _bndr2) = mkNonRecFloat env lev bndr1 rhs1         ; return (env2, floats1, Nothing) } @@ -660,7 +606,7 @@   | not (isJoinId (head bndrs))   = do { (env, bndrs1) <- cpCloneBndrs env bndrs        ; let env' = enterRecGroupRHSs env bndrs1-       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')+       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd Lifted env')                            bndrs1 rhss         ; let (zipManyFloats -> floats, rhss1) = unzip stuff@@ -709,18 +655,18 @@   ----------------cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool+cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity         -> CorePrepEnv -> OutId -> CoreExpr         -> UniqSM (Floats, CpeRhs) -- Used for all bindings -- The binder is already cloned, hence an OutId-cpePair top_lvl is_rec dmd is_unlifted env bndr rhs+cpePair top_lvl is_rec dmd lev env0 bndr rhs   = 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        ; let dec = want_float_from_rhs floats1 rhs1-       ; (floats2, rhs2) <- executeFloatDecision dec floats1 rhs1+       ; (floats2, rhs2) <- executeFloatDecision env dec floats1 rhs1         -- Make the arity match up        ; (floats3, rhs3)@@ -728,21 +674,23 @@                then return (floats2, cpeEtaExpand arity rhs2)                else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $                                -- Note [Silly extra arguments]-                    (do { v <- newVar (idType bndr)-                        ; let float = mkNonRecFloat env False v rhs2+                    (do { v <- newVar env (idType bndr)+                        ; let (float, v') = mkNonRecFloat env Lifted v rhs2                         ; return ( snocFloat floats2 float-                                 , cpeEtaExpand arity (Var v)) })+                                 , cpeEtaExpand arity (Var v')) })          -- Wrap floating ticks        ; let (floats4, rhs4) = wrapTicks floats3 rhs3         ; return (floats4, rhs4) }   where+    env = pushBinderContext bndr env0+     arity = idArity bndr        -- We must match this arity      want_float_from_rhs floats rhs       | isTopLevel top_lvl = wantFloatTop floats-      | otherwise          = wantFloatLocal is_rec dmd is_unlifted floats rhs+      | otherwise          = wantFloatLocal is_rec dmd lev floats rhs  {- Note [Silly extra arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -766,7 +714,9 @@ -- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils cpeJoinPair env bndr rhs   = assert (isJoinId bndr) $-    do { let JoinPoint join_arity = idJoinPointHood bndr+    do { let join_arity = case idJoinPointHood bndr of+                 JoinPoint join_arity -> join_arity+                 _ -> panic "cpeJoinPair"              (bndrs, body)        = collectNBinders join_arity rhs         ; (env', bndrs') <- cpCloneBndrs env bndrs@@ -839,9 +789,9 @@   = do { body <- cpeBodyNF env expr        ; return (emptyFloats, mkTick tickish' body) }   where-    tickish' | Breakpoint ext n fvs modl <- tickish+    tickish' | Breakpoint ext bid fvs <- tickish              -- See also 'substTickish'-             = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) modl+             = Breakpoint ext bid (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)              | otherwise              = tickish @@ -916,6 +866,7 @@ cpeRhsE env (Case scrut bndr ty alts)   = do { (floats, scrut') <- cpeBody env scrut        ; (env', bndr2) <- cpCloneBndr env bndr+       ; let bndr3 = bndr2 `setIdUnfolding` evaldUnfolding        ; let alts'                | cp_catchNonexhaustiveCases $ cpe_config env                  -- Suppose the alternatives do not cover all the data constructors of the type.@@ -931,10 +882,9 @@         ; case alts'' of            [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]-             | let is_unlifted = isUnliftedType (idType bndr2)-             , let float = mkCaseFloat is_unlifted bndr2 scrut'+             | let float = mkCaseFloat bndr3 scrut'              -> return (snocFloat floats float, rhs)-           _ -> return (floats, Case scrut' bndr2 (cpSubstTy env ty) alts'') }+           _ -> return (floats, Case scrut' bndr3 (cpSubstTy env ty) alts'') }   where     sat_alt env (Alt con bs rhs)        = do { (env2, bs') <- cpCloneBndrs env bs@@ -968,36 +918,36 @@ cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) cpeBody env expr   = do { (floats1, rhs) <- cpeRhsE env expr-       ; (floats2, body) <- rhsToBody rhs+       ; (floats2, body) <- rhsToBody env rhs        ; return (floats1 `appFloats` floats2, body) }  ---------rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)+rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody) -- Remove top level lambdas by let-binding -rhsToBody (Tick t expr)+rhsToBody env (Tick t expr)   | tickishScoped t == NoScope  -- only float out of non-scoped annotations-  = do { (floats, expr') <- rhsToBody expr+  = do { (floats, expr') <- rhsToBody env expr        ; return (floats, mkTick t expr') } -rhsToBody (Cast e co)+rhsToBody env (Cast e co)         -- You can get things like         --      case e of { p -> coerce t (\s -> ...) }-  = do { (floats, e') <- rhsToBody e+  = do { (floats, e') <- rhsToBody env e        ; return (floats, Cast e' co) } -rhsToBody expr@(Lam {})   -- See Note [No eta reduction needed in rhsToBody]+rhsToBody env expr@(Lam {})   -- See Note [No eta reduction needed in rhsToBody]   | all isTyVar bndrs           -- Type lambdas are ok   = return (emptyFloats, expr)   | otherwise                   -- Some value lambdas   = do { let rhs = cpeEtaExpand (exprArity expr) expr-       ; fn <- newVar (exprType rhs)+       ; fn <- newVar env (exprType rhs)        ; let float = Float (NonRec fn rhs) LetBound TopLvlFloatable        ; return (unitFloat float, Var fn) }   where     (bndrs,_) = collectBinders expr -rhsToBody expr = return (emptyFloats, expr)+rhsToBody _env expr = return (emptyFloats, expr)   {- Note [No eta reduction needed in rhsToBody]@@ -1169,10 +1119,9 @@         -- allocating CaseBound Floats for token and thing as needed         = do { (floats1, token) <- cpeArg env topDmd token              ; (floats2, thing) <- cpeBody env thing-             ; case_bndr <- newVar ty+             ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar env ty              ; let tup = mkCoreUnboxedTuple [token, Var case_bndr]-             ; let is_unlifted = False -- otherwise seq# would not type-check-             ; let float = mkCaseFloat is_unlifted case_bndr thing+             ; let float = mkCaseFloat case_bndr thing              ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) }      cpe_app env (Var v) args@@ -1263,8 +1212,8 @@      rebuild_app'         :: CorePrepEnv-        -> [ArgInfo] -- The arguments (inner to outer)-        -> CpeApp+        -> [ArgInfo] -- The arguments (inner to outer); substitution not applied+        -> CpeApp    -- Substitution already applied         -> Floats         -> [Demand]         -> [CoreTickish]@@ -1276,12 +1225,9 @@      rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of       -- See Note [Ticks and mandatory eta expansion]-      _-        | not (null rt_ticks)-        , req_depth <= 0-        ->-            let tick_fun = foldr mkTick fun' rt_ticks-            in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth+      _ | not (null rt_ticks), req_depth <= 0+        -> let tick_fun = foldr mkTick fun' rt_ticks+           in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth        AIApp (Type arg_ty)         -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth@@ -1299,7 +1245,7 @@                    (_   : ss_rest, True)  -> (topDmd, ss_rest)                    (ss1 : ss_rest, False) -> (ss1,    ss_rest)                    ([],            _)     -> (topDmd, [])-        (fs, arg') <- cpeArg top_env ss1 arg+        (fs, arg') <- cpeArg env ss1 arg         rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1)        AICast co@@ -1494,7 +1440,6 @@  Other considered designs ------------------------- One design that was rejected was to *require* that runRW#'s continuation be headed by a lambda. However, this proved to be quite fragile. For instance, SetLevels is very eager to float bottoming expressions. For instance given@@ -1576,10 +1521,10 @@        -> CoreArg -> UniqSM (Floats, CpeArg) cpeArg env dmd arg   = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda-       ; let arg_ty      = exprType arg1-             is_unlifted = isUnliftedType arg_ty-             dec         = wantFloatLocal NonRecursive dmd is_unlifted floats1 arg1-       ; (floats2, arg2) <- executeFloatDecision dec floats1 arg1+       ; let arg_ty = exprType arg1+             lev    = typeLevity arg_ty+             dec    = wantFloatLocal NonRecursive dmd lev floats1 arg1+       ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1                 -- Else case: arg1 might have lambdas, and we can't                 --            put them inside a wrapBinds @@ -1588,13 +1533,14 @@        -- see Note [ANF-ising literal string arguments]        ; if exprIsTrivial arg2          then return (floats2, arg2)-         else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty+         else do { v <- (`setIdDemandInfo` dmd) <$> newVar env arg_ty                        -- See Note [Pin demand info on floats]                  ; let arity = cpeArgArity env dec floats1 arg2                        arg3  = cpeEtaExpand arity arg2                        -- See Note [Eta expansion of arguments in CorePrep]-                 ; let arg_float = mkNonRecFloat env is_unlifted v arg3-                 ; return (snocFloat floats2 arg_float, varToCoreExpr v) }+                 ; let (arg_float, v') = mkNonRecFloat env lev v arg3+                 ---; pprTraceM "cpeArg" (ppr arg1 $$ ppr dec $$ ppr arg2)+                 ; return (snocFloat floats2 arg_float, varToCoreExpr v') }        }  cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity@@ -1664,7 +1610,7 @@     excess_arity  = (max fn_arity mark_arity) - n_args     sat_expr      = cpeEtaExpand excess_arity expr     applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) .-                               reverse . expectJust "maybeSaturate" $ (idCbvMarks_maybe fn))+                               reverse . expectJust $ (idCbvMarks_maybe fn))     -- For join points we never eta-expand (See Note [Do not eta-expand join points])     -- so we assert all arguments that need to be passed cbv are visible so that the     -- backend can evalaute them if required..@@ -1824,10 +1770,10 @@  Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pin demand info on floated lets, so that we can see the one-shot thunks.+We pin demand info on floated lets, so that we can see one-shot thunks. For example,   f (g x)-where `f` uses its argument at least once, creates a Float for `y = g x` and we+where `f` uses its argument at most once, creates a Float for `y = g x` and we should better pin appropriate demand info on `y`.  Note [Flatten case-binds]@@ -1838,7 +1784,7 @@ `case` out because `f` is strict.) In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind` -    Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl+    Float (a = case x of y { DEFAULT -> blah }) CaseBound top-lvl  with the call `f a`.  When we wrap that `Float` we will get @@ -1857,8 +1803,8 @@ into a FloatingBind of its own.  This is easily done in the Case equation for `cpsRhsE`.  Then our example will generate /two/ floats: -    Float (y = x)    CaseBound top_lvl-    Float (a = blah) CaseBound top_lvl+    Float (y = x)    CaseBound str-ctx+    Float (a = blah) CaseBound top-lvl  and we'll end up with nested cases. @@ -1871,6 +1817,45 @@ and the above footwork in cpsRhsE avoids generating a nested case.  +Note [Pin evaluatedness on floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When creating a new float `sat=e` in `mkNonRecFloat`, we propagate `sat` with an+`evaldUnfolding` if `e` is a value.++To see why, consider a call to a CBV function, such as a DataCon worker with+*strict* fields, in an argument context, such as++  data Box a = Box !a+  ... f (Box e) ...++where `f` is *lazy* and `e` is ok-for-spec, e.g. `e = I# (x +# 1#)`.+After ANFisation, we want to get the very nice code++  case x +# 1# of x' ->+  let sat = I# x' in+  let sat2 = Box sat in+  f sat2++Note that Case (2) of Note [wantFloatLocal] is in effect. That is,++  * x' is unlifted but ok-for-spec, hence floated out of the lazy arg of f+  * Since x' is unlifted, `I# x'` is a value, and so `sat` can be let-bound.+  * Since `sat` is a value, `Box sat` is a value as well, and so `sat2` can+    be let-bound.++Hence no thunk needs to be allocated! However, in order to recognise+`Box sat` as a value, it is crucial that the newly created `sat` has an+`evaldUnfolding`; otherwise the strict worker `Box` forces an eval on `sat`.+and we would get the far worse code++  let sat2 =+    case x +# 1# of x' ->+    case I# x' of sat' ->+    Box sat in+  f sat2++A live example of this is T24730, inspired by $walexGetByte.+ Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments@@ -2016,13 +2001,28 @@ Note [Controlling Speculative Evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the time, speculative evaluation has a positive effect on performance,-but we have found a case where speculative evaluation of dictionary functions-leads to a performance regression #25284.+Most of the time, speculative evaluation in the coreprep phase has a positive+effect on performance, however we have found that some forms of speculative+evaluation can lead to large performance regressions. See #25284. -Therefore we have some flags to control it. See the optimization section in-the User's Guide for the description of these flags and when to use them.+Therefore we have some flags to control which types of speculative evaluation+are done: +  -fspec-eval+     Globally enable/disable speculative evaluation ( -fno-spec-eval also turns+     off all other speculative evaluation). On by default for all+     optimization levels. Turning on this flag by itself should never cause+     a performance regression. Please open a ticket if you find any.++  -fspec-eval-dictfun+     Enable speculative evaluation for dictionary functions. Off by default+     since it can cause an increase in allocations (#24284). We have no+     examples that show a large performance improvement when turning on this+     flag. Please open a ticket if you find any.++Also see the optimization section in the User's Guide for the description of+these flags and when to use them.+ Note [Floats and FloatDecision] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have a special datatype `Floats` for modelling a telescope of `FloatingBind`@@ -2162,62 +2162,92 @@ zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats -mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind-mkCaseFloat is_unlifted bndr scrut-  = Float (NonRec bndr scrut) bound info+data FloatInfoArgs+  = FIA+  { fia_levity :: Levity+  , fia_demand :: Demand+  , fia_is_hnf :: Bool+  , fia_is_triv :: Bool+  , fia_is_string :: Bool+  , fia_is_dc_worker :: Bool+  , fia_ok_for_spec :: Bool+  }++defFloatInfoArgs :: Id -> CoreExpr -> FloatInfoArgs+defFloatInfoArgs bndr rhs+  = FIA+  { fia_levity = typeLevity (idType bndr)+  , fia_demand = idDemandInfo bndr -- mkCaseFloat uses evalDmd+  , fia_is_hnf = exprIsHNF rhs+  , fia_is_triv = exprIsTrivial rhs+  , fia_is_string = exprIsTickedString rhs+  , fia_is_dc_worker = isJust (isDataConId_maybe bndr) -- mkCaseFloat uses False+  , fia_ok_for_spec = False -- mkNonRecFloat uses exprOkForSpecEval+  }++decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo)+decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf,+                    fia_is_triv=is_triv, fia_is_string=is_string,+                    fia_is_dc_worker=is_dc_worker, fia_ok_for_spec=ok_for_spec}+  | Lifted <- lev, is_hnf, not is_triv = (LetBound, TopLvlFloatable)+      -- is_lifted: We currently don't allow unlifted values at the+      --            top-level or inside letrecs+      --            (but SG thinks that in principle, we should)+      -- is_triv:   Should not turn `case x of x' ->` into `let x' = x`+      --            when x is a HNF (cf. fun3 of T24264)+  | is_dc_worker          = (LetBound, TopLvlFloatable)+      -- We need this special case for nullary unlifted DataCon+      -- workers/wrappers (top-level bindings) until #17521 is fixed+  | is_string             = (CaseBound, TopLvlFloatable)+      -- String literals are unboxed (so must be case-bound) and float to+      -- the top-level+  | ok_for_spec           = (CaseBound, case lev of Unlifted -> LazyContextFloatable+                                                    Lifted   -> TopLvlFloatable)+      -- See Note [Speculative evaluation]+      -- Ok-for-spec-eval things will be case-bound, lifted or not.+      -- But when it's lifted we are ok with floating it to top-level+      -- (where it is actually bound lazily).+  | Unlifted <- lev       = (CaseBound, StrictContextFloatable)+  | isStrUsedDmd dmd      = (CaseBound, StrictContextFloatable)+      -- These will never be floated out of a lazy RHS context+  | Lifted   <- lev       = (LetBound, TopLvlFloatable)+      -- And these float freely but can't be speculated, hence LetBound++mkCaseFloat :: Id -> CpeRhs -> FloatingBind+mkCaseFloat bndr scrut+  = -- pprTrace "mkCaseFloat" (ppr bndr <+> ppr (bound,info)+    --                             -- <+> ppr is_lifted <+> ppr is_strict+    --                             -- <+> ppr ok_for_spec <+> ppr evald+    --                           $$ ppr scrut) $+    Float (NonRec bndr scrut) bound info   where-    (bound, info)-{--Eventually we want the following code, when #20749 is fixed.-      | is_lifted, is_hnf        = (LetBound,  TopLvlFloatable)-          -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should-          -- let-bind `StrictBox x'` after Note [Flatten case-binds].--}-      | exprIsTickedString scrut = (CaseBound, TopLvlFloatable)-          -- String literals are unboxed (so must be case-bound) and float to-          -- the top-level-      | otherwise                = (CaseBound, StrictContextFloatable)-         -- For a Case, we never want to drop the eval; hence no need to test-         -- for ok-for-spec-eval-    _is_lifted   = not is_unlifted-    _is_hnf      = exprIsHNF scrut+    !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr scrut)+      { fia_demand       = evalDmd+          -- Strict demand, so that we do not let-bind unless it's a value+      , fia_is_dc_worker = False+          -- DataCon worker *bindings* are never case-bound+      , fia_ok_for_spec  = False+          -- We do not currently float around case bindings.+          -- (ok-for-spec case bindings are unlikely anyway.)+      } -mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind-mkNonRecFloat env is_unlifted bndr rhs+mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeRhs -> (FloatingBind, Id)+mkNonRecFloat env lev bndr rhs   = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info)-    --                             <+> ppr is_lifted <+> ppr is_strict-    --                             <+> ppr ok_for_spec+    --                             <+> if is_strict then text "strict" else if is_lifted then text "lazy" else text "unlifted"+    --                             <+> if ok_for_spec then text "ok-for-spec" else empty+    --                             <+> if evald then text "evald" else empty     --                           $$ ppr rhs) $-    Float (NonRec bndr rhs) bound info+    (Float (NonRec bndr' rhs) bound info, bndr')   where-    (bound, info)-      | is_lifted, is_hnf        = (LetBound, TopLvlFloatable)-          -- is_lifted: We currently don't allow unlifted values at the-          --            top-level or inside letrecs-          --            (but SG thinks that in principle, we should)-      | is_data_con bndr         = (LetBound, TopLvlFloatable)-          -- We need this special case for nullary unlifted DataCon-          -- workers/wrappers (top-level bindings) until #17521 is fixed-      | exprIsTickedString rhs   = (CaseBound, TopLvlFloatable)-          -- String literals are unboxed (so must be case-bound) and float to-          -- the top-level-      | is_unlifted, ok_for_spec = (CaseBound, LazyContextFloatable)-      | is_lifted,   ok_for_spec = (CaseBound, TopLvlFloatable)-          -- See Note [Speculative evaluation]-          -- Ok-for-spec-eval things will be case-bound, lifted or not.-          -- But when it's lifted we are ok with floating it to top-level-          -- (where it is actually bound lazily).-      | is_unlifted || is_strict = (CaseBound, StrictContextFloatable)-          -- These will never be floated out of a lazy RHS context-      | otherwise                = assertPpr is_lifted (ppr rhs) $-                                   (LetBound, TopLvlFloatable)-          -- And these float freely but can't be speculated, hence LetBound+    !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr rhs)+      { fia_levity = lev+      , fia_is_hnf = is_hnf+      , fia_ok_for_spec = ok_for_spec+      } -    cfg         = cpe_config env-    is_lifted   = not is_unlifted     is_hnf      = exprIsHNF rhs-    dmd         = idDemandInfo bndr-    is_strict   = isStrUsedDmd dmd+    cfg         = cpe_config env      ok_for_spec = exprOkForSpecEval call_ok_for_spec rhs     -- See Note [Controlling Speculative Evaluation]@@ -2227,8 +2257,11 @@       | not (cp_specEvalDFun cfg) && isDFunId x = False       | otherwise                               = True     is_rec_call = (`elemUnVarSet` cpe_rec_ids env)-    is_data_con = isJust . isDataConId_maybe +    -- See Note [Pin evaluatedness on floats]+    bndr' | is_hnf    = bndr `setIdUnfolding` evaldUnfolding+          | otherwise = bndr+ -- | Wrap floats around an expression wrapBinds :: Floats -> CpeBody -> CpeBody wrapBinds floats body@@ -2270,7 +2303,7 @@   let x = let y = e1 in e2   in e Similarly for `(\x. e) (let y = e1 in e2)`.-Do we want to float out `y` out of `x`?+Do we want to float `y` out of `x`? (This is discussed in detail in the paper "Let-floating: moving bindings to give faster programs".) @@ -2334,13 +2367,17 @@   = FloatNone   | FloatAll -executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)-executeFloatDecision dec floats rhs+instance Outputable FloatDecision where+  ppr FloatNone = text "none"+  ppr FloatAll  = text "all"++executeFloatDecision :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)+executeFloatDecision env dec floats rhs   = case dec of       FloatAll                 -> return (floats, rhs)       FloatNone         | isEmptyFloats floats -> return (emptyFloats, rhs)-        | otherwise            -> do { (floats', body) <- rhsToBody rhs+        | otherwise            -> do { (floats', body) <- rhsToBody env rhs                                      ; return (emptyFloats, wrapBinds floats $                                                             wrapBinds floats' body) }             -- FloatNone case: `rhs` might have lambdas, and we can't@@ -2351,12 +2388,12 @@   | fs_info fs `floatsAtLeastAsFarAs` TopLvlFloatable = FloatAll   | otherwise                                         = FloatNone -wantFloatLocal :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> FloatDecision+wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeRhs -> FloatDecision -- See Note [wantFloatLocal]-wantFloatLocal is_rec rhs_dmd rhs_is_unlifted floats rhs+wantFloatLocal is_rec rhs_dmd rhs_lev floats rhs   |  isEmptyFloats floats -- Well yeah...   || isStrUsedDmd rhs_dmd -- Case (1) of Note [wantFloatLocal]-  || rhs_is_unlifted      -- dito+  || rhs_lev == Unlifted  -- dito   || (fs_info floats `floatsAtLeastAsFarAs` max_float_info && exprIsHNF rhs)                           -- Case (2) of Note [wantFloatLocal]   = FloatAll@@ -2479,6 +2516,8 @@         , cpe_subst :: Subst  -- ^ See Note [CorePrepEnv: cpe_subst]          , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]++        , cpe_context :: [OccName] -- ^ See Note [Binder context]     }  mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv@@ -2486,6 +2525,7 @@       { cpe_config        = cfg       , cpe_subst         = emptySubst       , cpe_rec_ids       = emptyUnVarSet+      , cpe_context       = []       }  extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv@@ -2526,6 +2566,14 @@ cpSubstCo (CPE { cpe_subst = subst }) co = substCo subst co           -- substCo has a short-cut if the TCvSubst is empty +-- | See Note [Binder context]+pushBinderContext :: Id -> CorePrepEnv -> CorePrepEnv+pushBinderContext ident env+  | lengthAtLeast (cpe_context env) 2+  = env+  | otherwise+  = env { cpe_context = getOccName ident : cpe_context env}+ ------------------------------------------------------------------------------ -- Cloning binders -- ---------------------------------------------------------------------------@@ -2614,10 +2662,20 @@ -- Generating new binders -- --------------------------------------------------------------------------- -newVar :: Type -> UniqSM Id-newVar ty- = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") ManyTy ty+newVar :: CorePrepEnv ->  Type -> UniqSM Id+newVar env ty+ -- See Note [Binder context]+ = seqType ty `seq` mkSysLocalOrCoVarM (fsLit occ) ManyTy ty+   where occ = intercalate "_" (map occNameString $ cpe_context env) ++ "_sat" +{- Note [Binder context]+   ~~~~~~~~~~~~~~~~~~~~~+   To ensure that the compiled program (specifically symbol names)+   remains understandable to the user we maintain a context+   of binders that we are currently under. This allows us to give+   identifiers conjured during CorePrep more contextually-meaningful+   names. This is done in `newVar`.+ -}  ------------------------------------------------------------------------------ -- Floating ticks@@ -2689,7 +2747,7 @@   let     platform = cp_platform (cpe_config env) -    -- Per the documentation in GHC.Num.BigNat, a BigNat# is:+    -- Per the documentation in GHC.Internal.Bignum.BigNat, a BigNat# is:     --   "Represented as an array of limbs (Word#) stored in     --   little-endian order (Word# themselves use machine order)."     --@@ -2750,7 +2808,7 @@   let     litAddrRhs = Lit (LitString words)       -- not "mkLitString"; that does UTF-8 encoding, which we don't want here-    litAddrFloat = mkNonRecFloat env True litAddrId litAddrRhs+    (litAddrFloat, litAddrId') = mkNonRecFloat env Unlifted litAddrId litAddrRhs      contentsLength = mkIntLit platform (toInteger (BS.length words)) @@ -2763,7 +2821,7 @@     copyContentsCall =       Var (primOpId CopyAddrToByteArrayOp)         `App` Type realWorldTy-        `App` Var litAddrId+        `App` Var litAddrId'         `App` Var mutableByteArrayId         `App` mkIntLit platform 0         `App` contentsLength
compiler/GHC/Data/Graph/Color.hs view
@@ -380,5 +380,3 @@     in   chooseColor --
compiler/GHC/Data/Graph/Inductive/Graph.hs view
@@ -70,6 +70,7 @@ import           Data.Function (on) import qualified Data.IntSet   as IntSet import           Data.List     (delete, groupBy, sort, sortBy, (\\))+import           Data.List.NonEmpty (nonEmpty) import           Data.Maybe    (fromMaybe, isJust)  import GHC.Utils.Panic@@ -167,11 +168,9 @@    -- | The minimum and maximum 'Node' in a 'Graph'.   nodeRange :: gr a b -> (Node,Node)-  nodeRange g-    | isEmpty g = panic "nodeRange of empty graph"-    | otherwise = (minimum vs, maximum vs)-    where-      vs = nodes g+  nodeRange g = case nonEmpty (nodes g) of+      Nothing -> panic "nodeRange of empty graph"+      Just vs -> (minimum vs, maximum vs)    -- | A list of all 'LEdge's in the 'Graph'.   labEdges  :: gr a b -> [LEdge b]
compiler/GHC/Driver/Config/Cmm.hs view
@@ -24,17 +24,5 @@   , cmmDoCmmSwitchPlans    = not (backendHasNativeSwitch (backend dflags))   , cmmSplitProcPoints     = not (backendSupportsUnsplitProcPoints (backend dflags))                              || not (platformTablesNextToCode platform)-  , cmmAllowMul2           = (ncg && x86ish) || llvm-  , cmmOptConstDivision    = not llvm   }   where platform                = targetPlatform dflags-        -- Copied from StgToCmm-        (ncg, llvm) = case backendPrimitiveImplementation (backend dflags) of-                          GenericPrimitives -> (False, False)-                          NcgPrimitives -> (True, False)-                          LlvmPrimitives -> (False, True)-                          JSPrimitives -> (False, False)-        x86ish  = case platformArch platform of-                    ArchX86    -> True-                    ArchX86_64 -> True-                    _          -> False
compiler/GHC/Driver/Config/Core/Rules.hs view
@@ -5,19 +5,15 @@ import GHC.Prelude  import GHC.Driver.Flags-import GHC.Driver.DynFlags ( DynFlags, gopt, targetPlatform, homeUnitId_ )+import GHC.Driver.DynFlags ( DynFlags, gopt, targetPlatform )  import GHC.Core.Rules.Config -import GHC.Unit.Types     ( primUnitId, bignumUnitId )- -- | Initialize RuleOpts from DynFlags initRuleOpts :: DynFlags -> RuleOpts initRuleOpts dflags = RuleOpts   { roPlatform                = targetPlatform dflags   , roNumConstantFolding      = gopt Opt_NumConstantFolding dflags   , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags-    -- disable bignum rules in ghc-prim and ghc-bignum itself-  , roBignumRules             = homeUnitId_ dflags /= primUnitId-                                && homeUnitId_ dflags /= bignumUnitId+  , roBignumRules             = True   }
compiler/GHC/Driver/Config/Linker.hs view
@@ -27,9 +27,8 @@     ld_filter = case platformOS (targetPlatform dflags) of                   OSSolaris2 -> sunos_ld_filter                   _          -> id-    sunos_ld_filter :: String -> String-    sunos_ld_filter = unlines . sunos_ld_filter' . lines-    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)+    sunos_ld_filter :: [String] -> [String]+    sunos_ld_filter x = if (undefined_found x && ld_warning_found x)                           then (ld_prefix x) ++ (ld_postfix x)                           else x     breakStartsWith x y = break (isPrefixOf x) y
compiler/GHC/Driver/Config/StgToCmm.hs view
@@ -82,6 +82,7 @@    , stgToCmmAllowIntMul2Instr         = (ncg && (x86ish || aarch64)) || llvm   , stgToCmmAllowWordMul2Instr        = (ncg && (x86ish || ppc || aarch64)) || llvm+  , stgToCmmAllowIntWord64X2MinMax    = (ncg && x86ish && isSse4_2Enabled dflags) || llvm   -- SIMD flags   , stgToCmmVecInstrsErr  = vec_err   , stgToCmmAvx           = isAvxEnabled                   dflags
+ compiler/GHC/Driver/Downsweep.hs view
@@ -0,0 +1,1547 @@+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+module GHC.Driver.Downsweep+  ( downsweep+  , downsweepThunk+  , downsweepInstalledModules+  , downsweepFromRootNodes+  , downsweepInteractiveImports+  , DownsweepMode(..)+   -- * Summary functions+  , summariseModule+  , summariseFile+  , summariseModuleInterface+  , SummariseResult(..)+  -- * Helper functions+  , instantiationNodes+  , checkHomeUnitsClosed+  ) where++import GHC.Prelude++import GHC.Platform.Ways++import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Phases+import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess)+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Messager+import GHC.Driver.MakeSem+import GHC.Driver.MakeAction+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Ppr++import GHC.Iface.Load++import GHC.Parser.Header+import GHC.Rename.Names+import GHC.Tc.Utils.Backpack+import GHC.Runtime.Context++import Language.Haskell.Syntax.ImpExp++import GHC.Data.Graph.Directed+import GHC.Data.FastString+import GHC.Data.Maybe      ( expectJust )+import qualified GHC.Data.Maybe as M+import GHC.Data.OsPath     ( unsafeEncodeUtf )+import GHC.Data.StringBuffer+import GHC.Data.Graph.Directed.Reachability+import qualified GHC.LanguageExtensions as LangExt++import GHC.Utils.Exception ( throwIO, SomeAsyncException )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.Fingerprint+import GHC.Utils.TmpFs+import GHC.Utils.Constants++import GHC.Types.Error+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.Unique.Map+import GHC.Types.PkgQual+import GHC.Types.Basic+++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Graph+import GHC.Unit.Module.Deps+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Module.Stage++import Data.Either ( rights, partitionEithers, lefts )+import qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )+import qualified Control.Monad.Catch as MC+import Data.Maybe+import Data.List (partition)+import Data.Time+import Data.List (unfoldr)+import Data.Bifunctor (first, bimap)+import System.Directory+import System.FilePath++import Control.Monad.Trans.Reader+import qualified Data.Map.Strict as M+import Control.Monad.Trans.Class+import System.IO.Unsafe (unsafeInterleaveIO)++{-+Note [Downsweep and the ModuleGraph]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The ModuleGraph stores the relationship between all the modules, units, and+instantiations in the current session.++When we do downsweep, we build up a new ModuleGraph, starting from the root+modules. By following all the dependencies we construct a graph which allows+us to answer questions about the transitive closure of the imports.++The module graph is accessible in the HscEnv.++When is this graph constructed?++1. In `--make` mode, we construct the graph before starting to do any compilation.++2. In `-c` (oneshot) mode, we construct the graph when we have calculated the+   ModSummary for the module we are compiling. The `ModuleGraph` is stored in a+   thunk, so it is only constructed when it is needed. This avoids reading+   the interface files of the whole transitive closure unless they are needed.++3. In some situations (such as loading plugins) we may need to construct the+   graph without having a ModSummary. In this case we use the `downsweepInstalledModules`+   function.++The result is having a uniform graph available for the whole compilation pipeline.++-}++-- This caches the answer to the question, if we are in this unit, what does+-- an import of this module mean.+type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo]++-----------------------------------------------------------------------------+--+-- | Downsweep (dependency analysis) for --make mode+--+-- Chase downwards from the specified root set, returning summaries+-- for all home modules encountered.  Only follow source-import+-- links.+--+-- We pass in the previous collection of summaries, which is used as a+-- cache to avoid recalculating a module summary if the source is+-- unchanged.+--+-- The returned ModuleGraph has one node for each home-package+-- module, plus one for any hs-boot files.  The imports of these nodes+-- are all there, including the imports of non-home-package modules.+--+-- This function is intendned for use by --make mode and will also insert+-- LinkNodes and InstantiationNodes for any home units.+--+-- It will also turn on code generation for any modules that need it by calling+-- 'enableCodeGenForTH'.+downsweep :: HscEnv+          -> (GhcMessage -> AnyGhcDiagnostic)+          -> Maybe Messager+          -> [ModSummary]+          -- ^ Old summaries+          -> [ModuleName]       -- Ignore dependencies on these; treat+                                -- them as if they were package modules+          -> Bool               -- True <=> allow multiple targets to have+                                --          the same module name; this is+                                --          very useful for ghc -M+          -> IO ([DriverMessages], ModuleGraph)+                -- The non-error elements of the returned list all have distinct+                -- (Modules, IsBoot) identifiers, unless the Bool is true in+                -- which case there can be repeats+downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do+  n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)+  (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary+  let closure_errs = checkHomeUnitsClosed unit_env+      unit_env = hsc_unit_env hsc_env++      all_errs = closure_errs ++ root_errs++  case all_errs of+    [] -> do+       (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []++       let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)++       let all_nodes = downsweep_nodes ++ unit_nodes+       let all_errs = downsweep_errs ++ other_errs++       let logger = hsc_logger hsc_env+           tmpfs = hsc_tmpfs hsc_env+       -- if we have been passed -fno-code, we enable code generation+       -- for dependencies of modules that have -XTemplateHaskell,+       -- otherwise those modules will fail to compile.+       -- See Note [-fno-code mode] #8025+       th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes++       return (all_errs, th_configured_nodes)+    _  -> return (all_errs, emptyMG)+  where+    summary = getRootSummary excl_mods old_summary_map++    -- A cache from file paths to the already summarised modules. The same file+    -- can be used in multiple units so the map is also keyed by which unit the+    -- file was used in.+    -- Reuse these if we can because the most expensive part of downsweep is+    -- reading the headers.+    old_summary_map :: M.Map (UnitId, FilePath) ModSummary+    old_summary_map =+      M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]++    -- Dependencies arising on a unit (backpack and module linking deps)+    unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]+    unitModuleNodes summaries uid hue =+      maybeToList (linkNodes summaries uid hue)++-- | Calculate the module graph starting from a single ModSummary. The result is a+-- thunk, which when forced will perform the downsweep. This is useful in oneshot+-- mode where the module graph may never be needed.+-- If downsweep fails, then the resulting errors are just thrown.+downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph+downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do+  debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..."+  ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []+  let dflags = hsc_dflags hsc_env+  liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)+                                   (initPrintConfig dflags)+                                   (initDiagOpts dflags)+                                   (GhcDriverMessage <$> unionManyMessages errs)+  return (mkModuleGraph mg)++-- | Construct a module graph starting from the interactive context.+-- Produces, a thunk, which when forced will perform the downsweep.+-- This graph contains the current interactive module, and its dependencies.+--+--  Invariant: The hsc_mod_graph already contains the relevant home modules which+--  might be imported by the interactive imports.+--+-- This is a first approximation for this function. There probably should also+-- be edges linking the interactive modules together. (Ie Ghci7 importing Ghci6+-- and so on)+-- See Note [runTcInteractive module graph]+downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph+downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do+  debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...")+  let imps = ic_imports (hsc_IC hsc_env)++  let interactive_mn = icInteractiveModule ic+  -- No sensible value for ModLocation.. if you hit this panic then you probably+  -- need to add proper support for modules without any source files to the driver.+  let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps)+  let key = moduleToMnk interactive_mn NotBoot+  let node_type = ModuleNodeFixed key ml++  -- The existing nodes in the module graph. This will be populated when GHCi runs+  -- :load. Any home package modules need to already be in here.+  let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ]++  (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes+  let interactive_node = ModuleNode module_edges node_type++  let all_nodes  = M.elems graph+  return $ mkModuleGraph (interactive_node : all_nodes)++  where+ --+    mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))+    -- A simple edge to a module from the same home unit+    mkEdge (IIModule n) =+      let+        mod_node_key = ModNodeKeyWithUid+          { mnkModuleName = GWIB (moduleName n) NotBoot+          , mnkUnitId =+              -- 'toUnitId' is safe here, as we can't import modules that+              -- don't have a 'UnitId'.+              toUnitId (moduleUnit n)+          }+        mod_node_edge =+          ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key)+      in Left mod_node_edge+    -- A complete import statement+    mkEdge (IIDecl i) =+      let lvl = convImportLevel (ideclLevelSpec i)+          wanted_mod = unLoc (ideclName i)+          is_boot = ideclSource i+          mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)+          unitId = homeUnitId $ hsc_home_unit hsc_env+      in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot)++loopFromInteractive :: HscEnv+                    -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]+                    -> M.Map NodeKey ModuleGraphNode+                    -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)+loopFromInteractive _ [] cached_nodes = return ([], cached_nodes)+loopFromInteractive hsc_env (edge:edges) cached_nodes =+  case edge of+    Left edge -> do+        (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes+        return (edge : edges, cached_nodes')+    Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do+      let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)+      let k _ loc mod =+            let key = moduleToMnk mod is_boot+            in return $ FoundHome (ModuleNodeFixed key loc)+      found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg []+      case found of+        -- Case 1: Home modules have to already be in the cache.+        FoundHome (ModuleNodeFixed mod _) -> do+          let edge = ModuleNodeEdge lvl (NodeKey_Module mod)+          -- Note: Does not perform any further downsweep as the module must already be in the cache.+          (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes+          return (edge : edges, cached_nodes')+        -- Case 2: External units may not be in the cache, if we haven't already initialised the+        -- module graph. We can construct the module graph for those here by calling loopUnit.+        External uid -> do+          let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env+              cached_nodes' = loopUnit hsc_env' cached_nodes [uid]+              edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid)+          (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes'+          return (edge : edges, cached_nodes')+        -- And if it's not found.. just carry on and hope.+        _ -> loopFromInteractive hsc_env edges cached_nodes+++-- | Create a module graph from a list of installed modules.+-- This is used by the loader when we need to load modules but there+-- isn't already an existing module graph. For example, when loading plugins+-- during initialisation.+--+-- If you call this function, then if the `Module` you request to downsweep can't+-- be found then this function will throw errors.+-- If you need to use this function elsewhere, then it would make sense to make it+-- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit.+-- At the moment, it is overfitted for what `get_reachable_nodes` needs.+downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph+downsweepInstalledModules hsc_env mods = do+    let+        (home_mods, external_mods) = partition (\u -> moduleUnitId u `elem` hsc_all_home_unit_ids hsc_env) mods+        installed_mods = map (fst . getModuleInstantiation) home_mods+        external_uids = map moduleUnitId external_mods++        process :: InstalledModule -> IO ModuleNodeInfo+        process i = do+          res <- findExactModule hsc_env i NotBoot+          case res of+            InstalledFound loc -> return $ ModuleNodeFixed (installedModuleToMnk i) loc+            -- It is an internal-ish error if this happens, since we any call to this function should+            -- already know that we can find the modules we need to load.+            _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i++    nodes <- mapM process installed_mods+    (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids++    -- Similarly here, we should really not get any errors, but print them out if we do.+    let dflags = hsc_dflags hsc_env+    liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)+                                     (initPrintConfig dflags)+                                     (initDiagOpts dflags)+                                     (GhcDriverMessage <$> unionManyMessages errs)++    return (mkModuleGraph mg)++++-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used+-- by --make mode, and fixed nodes by oneshot mode.+--+-- See Note [Module Types in the ModuleGraph] for the difference between the two.+data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed++-- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root+-- 'UnitId's.+-- This function will start at the given roots, and traverse downwards to find+-- all the dependencies, all the way to the leaf units.+downsweepFromRootNodes :: HscEnv+                  -> M.Map (UnitId, FilePath) ModSummary+                  -> [ModuleName]+                  -> Bool+                  -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies+                  -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo+                  -> [UnitId] -- ^ The starting units+                  -> IO ([DriverMessages], [ModuleGraphNode])+downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids+   = do+       let root_map = mkRootMap root_nodes+       checkDuplicates root_map+       let env = DownsweepEnv hsc_env mode old_summaries excl_mods+       (deps', map0) <- runDownsweepM env  $ do+                    (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)+                    let all_deps = loopUnit hsc_env module_deps root_uids+                    let all_instantiations =  getHomeUnitInstantiations hsc_env+                    deps' <- loopInstantiations all_instantiations all_deps+                    return (deps', map0)+++       let downsweep_errs = lefts $ concat $ M.elems map0+           downsweep_nodes = M.elems deps'++       return (downsweep_errs, downsweep_nodes)+     where+        getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]+        getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++  instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)++        -- In a root module, the filename is allowed to diverge from the module+        -- name, so we have to check that there aren't multiple root files+        -- defining the same module (otherwise the duplicates will be silently+        -- ignored, leading to confusing behaviour).+        checkDuplicates+          :: DownsweepCache+          -> IO ()+        checkDuplicates root_map+           | not allow_dup_roots+           , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root+           | otherwise = pure ()+           where+             dup_roots :: [[ModuleNodeInfo]]        -- Each at least of length 2+             dup_roots = filterOut isSingleton $ map rights (M.elems root_map)+++calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]+calcDeps ms =+  -- Add a dependency on the HsBoot file if it exists+  -- This gets passed to the loopImports function which just ignores it if it+  -- can't be found.+  [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] +++  [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ]+++type DownsweepM a = ReaderT DownsweepEnv IO a+data DownsweepEnv = DownsweepEnv {+      downsweep_hsc_env :: HscEnv+    , _downsweep_mode :: DownsweepMode+    , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary+    , _downsweep_excl_mods :: [ModuleName]+}++runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a+runDownsweepM env act = runReaderT act env+++loopInstantiations :: [(UnitId, InstantiatedUnit)]+                   -> M.Map NodeKey ModuleGraphNode+                   -> DownsweepM (M.Map NodeKey ModuleGraphNode)+loopInstantiations [] done = pure done+loopInstantiations ((home_uid, iud) :xs) done = do+  hsc_env <- asks downsweep_hsc_env+  let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)+  let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env+      done' = loopUnit hsc_env' done [instUnitInstanceOf iud]+      payload = InstantiationNode home_uid iud+  loopInstantiations xs (M.insert (mkNodeKey payload) payload done')+++-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit+loopSummaries :: [ModSummary]+      -> (M.Map NodeKey ModuleGraphNode,+            DownsweepCache)+      -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)+loopSummaries [] done = pure done+loopSummaries (ms:next) (done, summarised)+  | Just {} <- M.lookup k done+  = loopSummaries next (done, summarised)+  -- Didn't work out what the imports mean yet, now do that.+  | otherwise = do+     (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised+     -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.+     (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'+     loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')+  where+    k = NodeKey_Module (msKey ms)++    hs_file_for_boot+      | HsBootFile <- ms_hsc_src ms+      = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))+      | otherwise+      = Nothing++loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)+loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is++loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)+loopModuleNodeInfo mod_node_info (done, summarised) = do+  case mod_node_info of+    ModuleNodeCompile ms -> do+      loopSummaries [ms] (done, summarised)+    ModuleNodeFixed mod ml -> do+      done' <- loopFixedModule mod ml done+      return (done', summarised)++-- NB: loopFixedModule does not take a downsweep cache, because if you+-- ever reach a Fixed node, everything under that also must be fixed.+loopFixedModule :: ModNodeKeyWithUid -> ModLocation+                -> M.Map NodeKey ModuleGraphNode+                -> DownsweepM (M.Map NodeKey ModuleGraphNode)+loopFixedModule key loc done = do+  let nk = NodeKey_Module key+  hsc_env <- asks downsweep_hsc_env+  case M.lookup nk done of+    Just {} -> return done+    Nothing -> do+      -- MP: TODO, we should just read the dependency info from the interface rather than either+      -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)+      -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)+      read_result <- liftIO $+        -- 1. Check if the interface is already loaded into the EPS by some other+        -- part of the compiler.+        lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case+          Just iface -> return (M.Succeeded iface)+          Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)+      case read_result of+        M.Succeeded iface -> do+          -- Computer information about this node+          let node_deps = ifaceDeps (mi_deps iface)+              edges = map mkFixedEdge node_deps+              node = ModuleNode edges (ModuleNodeFixed key loc)+          foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)+        -- Ignore any failure, we might try to read a .hi-boot file for+        -- example, even if there is not one.+        M.Failed {} ->+          return done++loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM  (M.Map NodeKey ModuleGraphNode)+loopFixedNodeKey _ done (Left key) = do+  loopFixedImports [key] done+loopFixedNodeKey home_uid done (Right uid) = do+  -- Set active unit so that looking loopUnit finds the correct+  -- -package flags in the unit state.+  hsc_env <- asks downsweep_hsc_env+  let hsc_env' = hscSetActiveUnitId home_uid hsc_env+  return $ loopUnit hsc_env' done [uid]++mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge+mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)+mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)++ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]+ifaceDeps deps =+  [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)+  | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)+  ] +++  [ Right (tcImportLevel lvl, uid)+  | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)+  ]++-- Like loopImports, but we already know exactly which module we are looking for.+loopFixedImports :: [ModNodeKeyWithUid]+                 -> M.Map NodeKey ModuleGraphNode+                 -> DownsweepM (M.Map NodeKey ModuleGraphNode)+loopFixedImports [] done = pure done+loopFixedImports (key:keys) done = do+  let nk = NodeKey_Module key+  hsc_env <- asks downsweep_hsc_env+  case M.lookup nk done of+    Just {} -> loopFixedImports keys done+    Nothing -> do+      read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)+      case read_result of+        InstalledFound loc -> do+          done' <- loopFixedModule key loc done+          loopFixedImports keys done'+        _otherwise ->+          -- If the finder fails, just keep going, there will be another+          -- error later.+          loopFixedImports keys done++downsweepSummarise :: HomeUnit+                   -> IsBootInterface+                   -> Located ModuleName+                   -> PkgQual+                   -> Maybe (StringBuffer, UTCTime)+                   -> DownsweepM SummariseResult+downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do+  DownsweepEnv hsc_env mode old_summaries excl_mods <- ask+  case mode of+    DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods+    DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods+++-- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover+-- a new module by doing this.+loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]+                -- Work list: process these modules+     -> M.Map NodeKey ModuleGraphNode+     -> DownsweepCache+                -- Visited set; the range is a list because+                -- the roots can have the same module names+                -- if allow_dup_roots is True+     -> DownsweepM ([ModuleNodeEdge],+          M.Map NodeKey ModuleGraphNode, DownsweepCache)+                -- The result is the completed NodeMap+loopImports [] done summarised = return ([], done, summarised)+loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised+  | Just summs <- M.lookup cache_key summarised+  = case summs of+      [Right ms] -> do+        let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))+        (rest, summarised', done') <- loopImports ss done summarised+        return (nk: rest, summarised', done')+      [Left _err] ->+        loopImports ss done summarised+      _errs ->  do+        loopImports ss done summarised+  | otherwise+  = do+       hsc_env <- asks downsweep_hsc_env+       let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)+       mb_s <- downsweepSummarise home_unit+                               is_boot wanted_mod mb_pkg+                               Nothing+       case mb_s of+           NotThere -> loopImports ss done summarised+           External uid -> do+            -- Pass an updated hsc_env to loopUnit, as each unit might+            -- have a different visible package database.+            let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env+            let done' = loopUnit hsc_env' done [uid]+            (other_deps, done'', summarised') <- loopImports ss done' summarised+            return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')+           FoundInstantiation iud -> do+            (other_deps, done', summarised') <- loopImports ss done summarised+            return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')+           FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)+           FoundHome s -> do+             (done', summarised') <-+               loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)+             (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'++             -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.+             return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)+  where+    cache_key = (home_uid, mb_pkg, unLoc <$> gwib)+    GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib+    wanted_mod = L loc mod++loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode+loopUnit _ cache [] = cache+loopUnit lcl_hsc_env cache (u:uxs) = do+   let nk = (NodeKey_ExternalUnit u)+   case Map.lookup nk cache of+     Just {} -> loopUnit lcl_hsc_env cache uxs+     Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of+                 Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs+                 Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)++multiRootsErr :: [ModuleNodeInfo] -> IO ()+multiRootsErr [] = panic "multiRootsErr"+multiRootsErr summs@(summ1:_)+  = throwOneError $ fmap GhcDriverMessage $+    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files+  where+    mod = moduleNodeInfoModule summ1+    files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs++moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages+moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod)++-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.+-- These are used to represent the type checking that is done after+-- all the free holes (sigs in current package) relevant to that instantiation+-- are compiled. This is necessary to catch some instantiation errors.+instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)]+instantiationNodes uid unit_state = map (uid,) iuids_to_check+  where+    iuids_to_check :: [InstantiatedUnit]+    iuids_to_check =+      nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state)+     where+      goUnitId uid =+        [ recur+        | VirtUnit indef <- [uid]+        , inst <- instUnitInsts indef+        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst+        ]++-- The linking plan for each module. If we need to do linking for a home unit+-- then this function returns a graph node which depends on all the modules in the home unit.++-- At the moment nothing can depend on these LinkNodes.+linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)+linkNodes summaries uid hue =+  let dflags = homeUnitEnv_dflags hue+      ofile = outputFile_ dflags++      unit_nodes :: [NodeKey]+      unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)+  -- Issue a warning for the confusing case where the user+  -- said '-o foo' but we're not going to do any linking.+  -- We attempt linking if either (a) one of the modules is+  -- called Main, or (b) the user said -no-hs-main, indicating+  -- that main() is going to come from somewhere else.+  --+      no_hs_main = gopt Opt_NoHsMain dflags++      main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes++      do_linking =  main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib++  in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking ->+            Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))+        -- This should be an error, not a warning (#10895).+        | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))+        | otherwise  -> Nothing++getRootSummary ::+  [ModuleName] ->+  M.Map (UnitId, FilePath) ModSummary ->+  HscEnv ->+  Target ->+  IO (Either DriverMessages ModSummary)+getRootSummary excl_mods old_summary_map hsc_env target+  | TargetFile file mb_phase <- targetId+  = do+    let offset_file = augmentByWorkingDirectory dflags file+    exists <- liftIO $ doesFileExist offset_file+    if exists || isJust maybe_buf+    then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase+         maybe_buf+    else+      return $ Left $ singleMessage $+      mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)+  | TargetModule modl <- targetId+  = do+    maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot+                     (L rootLoc modl) (ThisPkg (homeUnitId home_unit))+                     maybe_buf excl_mods+    pure case maybe_summary of+      FoundHome (ModuleNodeCompile s)  -> Right s+      FoundHomeWithError err -> Left (snd err)+      _ -> Left (moduleNotFoundErr uid modl)+    where+      Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target+      home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+      rootLoc = mkGeneralSrcSpan (fsLit "<command line>")+      dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))++-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline+-- system.+-- Create bundles of 'Target's wrapped in a 'MakeAction' that uses+-- 'withAbstractSem' to wait for a free slot, limiting the number of+-- concurrently computed summaries to the value of the @-j@ option or the slots+-- allocated by the job server, if that is used.+--+-- The 'MakeAction' returns 'Maybe', which is not handled as an error, because+-- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the+-- result won't be read anyway here.+--+-- To emulate the current behavior, we funnel exceptions past the concurrency+-- barrier and rethrow the first one afterwards.+rootSummariesParallel ::+  WorkerLimit ->+  HscEnv ->+  (GhcMessage -> AnyGhcDiagnostic) ->+  Maybe Messager ->+  (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) ->+  IO ([DriverMessages], [ModSummary])+rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do+  (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles)+  runPipelines n_jobs hsc_env diag_wrapper msg actions+  (sequence . catMaybes <$> sequence get_results) >>= \case+    Right results -> pure (partitionEithers (concat results))+    Left exc -> throwIO exc+  where+    bundles = mk_bundles targets++    mk_bundles = unfoldr \case+      [] -> Nothing+      ts -> Just (splitAt bundle_size ts)++    bundle_size = 20++    targets = hsc_targets hsc_env++    action_and_result (log_queue_id, ts) = do+      res_var <- liftIO newEmptyMVar+      pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var)++    action log_queue_id target_bundle = do+      env@MakeEnv {compile_sem} <- ask+      lift $ lift $+        withAbstractSem compile_sem $+        withLoggerHsc log_queue_id env \ lcl_hsc_env ->+          MC.try (mapM (get_summary lcl_hsc_env) target_bundle) >>= \case+            Left e | Just (_ :: SomeAsyncException) <- fromException e ->+              throwIO e+            a -> pure a++-- | This function checks then important property that if both p and q are home units+-- then any dependency of p, which transitively depends on q is also a home unit.+--+-- See Note [Multiple Home Units], section 'Closure Property'.+checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]+checkHomeUnitsClosed ue+    | Set.null bad_unit_ids = []+    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]+  where+    home_id_set = HUG.allUnits $ ue_home_unit_graph ue+    bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}+    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")++    downwards_closure :: Graph (Node UnitId UnitId)+    downwards_closure = graphFromEdgedVerticesUniq graphNodes++    inverse_closure = graphReachability $ transposeG downwards_closure++    upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]++    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)+    all_unit_direct_deps+      = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue+      where+        go rest this this_uis =+           plusUniqMap_C Set.union+             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))+             rest+           where+             external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)+             this_units = homeUnitEnv_units this_uis+             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]++    graphNodes :: [Node UnitId UnitId]+    graphNodes = go Set.empty home_id_set+      where+        go done todo+          = case Set.minView todo of+              Nothing -> []+              Just (uid, todo')+                | Set.member uid done -> go done todo'+                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of+                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))+                    Just depends ->+                      let todo'' = (depends Set.\\ done) `Set.union` todo'+                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''++-- | Update the every ModSummary that is depended on+-- by a module that needs template haskell. We enable codegen to+-- the specified target, disable optimization and change the .hi+-- and .o file locations to be temporary files.+-- See Note [-fno-code mode]+enableCodeGenForTH+  :: Logger+  -> TmpFs+  -> UnitEnv+  -> [ModuleGraphNode]+  -> IO ModuleGraph+enableCodeGenForTH logger tmpfs unit_env =+  enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env+++data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord)++instance Outputable CodeGenEnable where+  ppr = text . show++-- | Helper used to implement 'enableCodeGenForTH'.+-- In particular, this enables+-- unoptimized code generation for all modules that meet some+-- condition (first parameter), or are dependencies of those+-- modules. The second parameter is a condition to check before+-- marking modules for code generation.+enableCodeGenWhen+  :: Logger+  -> TmpFs+  -> TempFileLifetime+  -> TempFileLifetime+  -> UnitEnv+  -> [ModuleGraphNode]+  -> IO ModuleGraph+enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do+  mgMapM enable_code_gen mg+  where+    defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)++    enable_code_gen :: ModuleNodeInfo -> IO ModuleNodeInfo+    enable_code_gen (ModuleNodeCompile ms) = ModuleNodeCompile <$> enable_code_gen_ms ms+    enable_code_gen m@(ModuleNodeFixed {}) = return m++    -- FIXME: Strong resemblance and some duplication between this and `makeDynFlagsConsistent`.+    -- It would be good to consider how to make these checks more uniform and not duplicated.+    enable_code_gen_ms :: ModSummary -> IO ModSummary+    enable_code_gen_ms ms+      | ModSummary+        { ms_location = ms_location+        , ms_hsc_src = HsSrcFile+        , ms_hspp_opts = dflags+        } <- ms+      , Just enable_spec <- needs_codegen_map ms =+      if | nocode_enable ms -> do+               let new_temp_file suf dynsuf = do+                     tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf+                     let dyn_tn = tn -<.> dynsuf+                     addFilesToClean tmpfs dynLife [dyn_tn]+                     return (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn)+                 -- We don't want to create .o or .hi files unless we have been asked+                 -- to by the user. But we need them, so we patch their locations in+                 -- the ModSummary with temporary files.+                 --+               ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-+                 -- If ``-fwrite-interface` is specified, then the .o and .hi files+                 -- are written into `-odir` and `-hidir` respectively.  #16670+                 if gopt Opt_WriteInterface dflags+                   then return ((ml_hi_file_ospath ms_location, ml_dyn_hi_file_ospath ms_location)+                               , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location))+                   else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))+                            <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))+               let new_dflags = case enable_spec of+                                  EnableByteCode -> dflags { backend = interpreterBackend }+                                  EnableObject   -> dflags { backend = defaultBackendOf ms }+                                  EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}+               let ms' = ms+                     { ms_location =+                         ms_location { ml_hi_file_ospath = hi_file+                                     , ml_obj_file_ospath = o_file+                                     , ml_dyn_hi_file_ospath = dyn_hi_file+                                     , ml_dyn_obj_file_ospath = dyn_o_file }+                     , ms_hspp_opts = updOptLevel 0 $ new_dflags+                     }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'++         -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough)+         -- we only get to this case if the default backend is already generating object files, but we need dynamic+         -- objects+         | bytecode_and_enable enable_spec ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode+                     }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'+         | dynamic_too_enable enable_spec ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo+                     }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'+         | ext_interp_enable ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter+                     }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'++         | needs_full_ways dflags -> do+               let ms' = ms { ms_hspp_opts = set_full_ways dflags }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'++         | otherwise -> return ms++    enable_code_gen_ms ms = return ms++    nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =+      not (backendGeneratesCode (backend dflags)) &&+      -- Don't enable codegen for TH on indefinite packages; we+      -- can't compile anything anyway! See #16219.+      isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)++    bytecode_and_enable enable_spec ms =+      -- In the situation where we **would** need to enable dynamic-too+      -- IF we had decided we needed objects+      dynamic_too_enable EnableObject ms+        -- but we prefer to use bytecode rather than objects+        && prefer_bytecode+        -- and we haven't already turned it on+        && not generate_both+      where+        lcl_dflags   = ms_hspp_opts ms+        prefer_bytecode = case enable_spec of+                            EnableByteCodeAndObject -> True+                            EnableByteCode -> True+                            EnableObject -> False++        generate_both   = gopt Opt_ByteCodeAndObjectCode lcl_dflags++    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so+    -- the linker can correctly load the object files.  This isn't necessary+    -- when using -fexternal-interpreter.+    -- FIXME: Duplicated from makeDynFlagsConsistent+    dynamic_too_enable enable_spec ms+      | sTargetRTSLinkerOnlySupportsSharedLibs $ settings lcl_dflags =+          not isDynWay && not dyn_too_enabled+            && enable_object+      | otherwise =+          hostIsDynamic && not hostIsProfiled && internalInterpreter &&+            not isDynWay && not isProfWay &&  not dyn_too_enabled+              && enable_object+      where+       lcl_dflags   = ms_hspp_opts ms+       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)+       dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags+       isDynWay    = hasWay (ways lcl_dflags) WayDyn+       isProfWay   = hasWay (ways lcl_dflags) WayProf+       enable_object = case enable_spec of+                            EnableByteCode -> False+                            EnableByteCodeAndObject -> True+                            EnableObject -> True++    -- #16331 - when no "internal interpreter" is available but we+    -- need to process some TemplateHaskell or QuasiQuotes, we automatically+    -- turn on -fexternal-interpreter.+    ext_interp_enable ms = not ghciSupported && internalInterpreter+      where+       lcl_dflags   = ms_hspp_opts ms+       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)+++    mg = mkModuleGraph mod_graph++    (td_map, lookup_node) = mkStageDeps mod_graph++    queryReachable ns = isReachableMany td_map (mapMaybe lookup_node ns)++    -- NB: Do not inline these, it is very important to share them across all calls+    -- to needs_obj_set and needs_bc_set.+    !query_obj =+      let !deps = queryReachable need_obj_set+      in \k -> deps (expectJust $ lookup_node k)++    !query_bc  =+      let !deps = queryReachable need_bc_set+      in \k -> deps (expectJust $ lookup_node k)++    -- The direct dependencies of modules which require object code+    need_obj_set =++        -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only+        -- it's dependencies.+        [ (mkNodeKey m, RunStage)+        | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph+        , isTemplateHaskellOrQQNonBoot ms+        , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))+        ]++    -- The direct dependencies of modules which require byte code+    need_bc_set =+        [ (mkNodeKey m, RunStage)+        | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph+        , isTemplateHaskellOrQQNonBoot ms+        , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)+        ]++    needs_obj_set, needs_bc_set :: ModNodeKeyWithUid -> Bool+    needs_obj_set k = query_obj (NodeKey_Module k, CompileStage)++    needs_bc_set k = query_bc  (NodeKey_Module k, CompileStage)++    -- A map which tells us how to enable code generation for a NodeKey+    needs_codegen_map :: ModSummary -> Maybe CodeGenEnable+    needs_codegen_map ms =+      let nk = msKey ms+++      -- Another option here would be to just produce object code, rather than both object and+      -- byte code+      in case (needs_obj_set nk, needs_bc_set nk) of+        (True, True)   -> Just EnableByteCodeAndObject+        (True, False)  -> Just EnableObject+        (False, True)  -> Just EnableByteCode+        (False, False) -> Nothing++    -- FIXME: Duplicated from makeDynFlagsConsistent+    needs_full_ways dflags+      = ghcLink dflags == LinkInMemory &&+        not (gopt Opt_ExternalInterpreter dflags) &&+        targetWays_ dflags /= hostFullWays+    set_full_ways dflags =+        let platform = targetPlatform dflags+            dflags_a = dflags { targetWays_ = hostFullWays }+            dflags_b = foldl gopt_set dflags_a+                     $ concatMap (wayGeneralFlags platform)+                                 hostFullWays+            dflags_c = foldl gopt_unset dflags_b+                     $ concatMap (wayUnsetGeneralFlags platform)+                                 hostFullWays+        in dflags_c++{- Note [-fno-code mode]+~~~~~~~~~~~~~~~~~~~~~~~~+GHC offers the flag -fno-code for the purpose of parsing and typechecking a+program without generating object files. This is intended to be used by tooling+and IDEs to provide quick feedback on any parser or type errors as cheaply as+possible.++When GHC is invoked with -fno-code, no object files or linked output will be+generated. As many errors and warnings as possible will be generated, as if+-fno-code had not been passed. The session DynFlags will have+backend == NoBackend.++-fwrite-interface+~~~~~~~~~~~~~~~~+Whether interface files are generated in -fno-code mode is controlled by the+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is+not also passed. Recompilation avoidance requires interface files, so passing+-fno-code without -fwrite-interface should be avoided. If -fno-code were+re-implemented today, there would be no need for -fwrite-interface as it+would considered always on; this behaviour is as it is for backwards compatibility.++================================================================+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER+================================================================++Template Haskell+~~~~~~~~~~~~~~~~+A module using Template Haskell may invoke an imported function from inside a+splice. This will cause the type-checker to attempt to execute that code, which+would fail if no object files had been generated. See #8025. To rectify this,+during the downsweep we patch the DynFlags in the ModSummary of any home module+that is imported by a module that uses Template Haskell to generate object+code.++The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled+or not in the module which needs the code generation. If the module requires byte-code then+dependencies will generate byte-code, otherwise they will generate object files.+In the case where some modules require byte-code and some object files, both are+generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these+configurations.++The object files (and interface files if -fwrite-interface is disabled) produced+for Template Haskell are written to temporary files.++Note that since Template Haskell can run arbitrary IO actions, -fno-code mode+is no more secure than running without it.++Explicit Level Imports+~~~~~~~~~~~~~~~~~~~~~~+When `-XExplicitLevelImports` is enabled, code is only generated for modules+needed for the compile stage. The ReachabilityIndex created by `mkStageDeps` answers+the question, if I compile a module for a specific stage, then which modules at+other stages do I need. The roots of this query are the modules which use `TemplateHaskell`+at the runtime stage, and modules we need code generation for are those which+are needed at the compile time stage. All the logic about how ExplicitLevelImports+and TemplateHaskell affect the needed stages of a module is encoded in mkStageDeps.++Potential TODOS:+~~~~~+* Remove -fwrite-interface and have interface files always written in -fno-code+  mode+* Both .o and .dyn_o files are generated for template haskell, but we only need+  .dyn_o (for dynamically linked compilers) Fix it. (The needed way is 'hostFullWays')+* In make mode, a message like+  Compiling A (A.hs, /tmp/ghc_123.o)+  is shown if downsweep enabled object code generation for A. Perhaps we should+  show "nothing" or "temporary object file" instead. Note that one+  can currently use -keep-tmp-files and inspect the generated file with the+  current behaviour.+* Offer a -no-codedir command line option, and write what were temporary+  object files there. This would speed up recompilation.+* Use existing object files (if they are up to date) instead of always+  generating temporary ones.+-}++-- | Populate the Downsweep cache with the root modules.+mkRootMap+  :: [ModuleNodeInfo]+  -> DownsweepCache+mkRootMap summaries = Map.fromListWith (flip (++))+  [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ]++-----------------------------------------------------------------------------+-- Summarising modules++-- We have two types of summarisation:+--+--    * Summarise a file.  This is used for the root module(s) passed to+--      cmLoadModules.  The file is read, and used to determine the root+--      module name.  The module name may differ from the filename.+--+--    * Summarise a module.  We are given a module name, and must provide+--      a summary.  The finder is used to locate the file in which the module+--      resides.++summariseFile+        :: HscEnv+        -> HomeUnit+        -> M.Map (UnitId, FilePath) ModSummary    -- old summaries+        -> FilePath                     -- source file name+        -> Maybe Phase                  -- start phase+        -> Maybe (StringBuffer,UTCTime)+        -> IO (Either DriverMessages ModSummary)++summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf+        -- we can use a cached summary if one is available and the+        -- source file hasn't changed,+   | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries+   = do+        let location = ms_location $ old_summary++        src_hash <- get_src_hash+                -- The file exists; we checked in getRootSummary above.+                -- If it gets removed subsequently, then this+                -- getFileHash may fail, but that's the right+                -- behaviour.++                -- return the cached summary if the source didn't change+        checkSummaryHash+            hsc_env (new_summary src_fn)+            old_summary location src_hash++   | otherwise+   = do src_hash <- get_src_hash+        new_summary src_fn src_hash+  where+    -- change the main active unit so all operations happen relative to the given unit+    hsc_env = hscSetActiveHomeUnit home_unit hsc_env'+    -- src_fn does not necessarily exist on the filesystem, so we need to+    -- check what kind of target we are dealing with+    get_src_hash = case maybe_buf of+                      Just (buf,_) -> return $ fingerprintStringBuffer buf+                      Nothing -> liftIO $ getFileHash src_fn++    new_summary src_fn src_hash = runExceptT $ do+        preimps@PreprocessedImports {..}+            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf++        let fopts = initFinderOpts (hsc_dflags hsc_env)+            (basename, extension) = splitExtension src_fn++            hsc_src+              | isHaskellSigSuffix (drop 1 extension) = HsigFile+              | isHaskellBootSuffix (drop 1 extension) = HsBootFile+              | otherwise = HsSrcFile++            -- Make a ModLocation for this file, adding the @-boot@ suffix to+            -- all paths if the original was a boot file.+            location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src++        -- Tell the Finder cache where it is, so that subsequent calls+        -- to findModule will find it, even if it's not on any search path+        mod <- liftIO $ do+          let home_unit = hsc_home_unit hsc_env+          let fc        = hsc_FC hsc_env+          addHomeModuleToFinder fc home_unit pi_mod_name location hsc_src++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_hash = src_hash+            , nms_hsc_src = hsc_src+            , nms_location = location+            , nms_mod = mod+            , nms_preimps = preimps+            }++checkSummaryHash+    :: HscEnv+    -> (Fingerprint -> IO (Either e ModSummary))+    -> ModSummary -> ModLocation -> Fingerprint+    -> IO (Either e ModSummary)+checkSummaryHash+  hsc_env new_summary+  old_summary+  location src_hash+  | ms_hs_hash old_summary == src_hash &&+      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do+           -- update the object-file timestamp+           obj_timestamp <- modificationTimeIfExists (ml_obj_file location)++           -- We have to repopulate the Finder's cache for file targets+           -- because the file might not even be on the regular search path+           -- and it was likely flushed in depanal. This is not technically+           -- needed when we're called from sumariseModule but it shouldn't+           -- hurt.+           let fc      = hsc_FC hsc_env+               mod     = ms_mod old_summary+               hsc_src = ms_hsc_src old_summary+           addModuleToFinder fc mod location hsc_src++           hi_timestamp <- modificationTimeIfExists (ml_hi_file location)+           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)++           return $ Right+             ( old_summary+                     { ms_obj_date = obj_timestamp+                     , ms_iface_date = hi_timestamp+                     , ms_hie_date = hie_timestamp+                     }+             )++   | otherwise =+           -- source changed: re-summarise.+           new_summary src_hash++data SummariseResult =+        FoundInstantiation InstantiatedUnit+      | FoundHomeWithError (UnitId, DriverMessages)+      | FoundHome ModuleNodeInfo+      | External UnitId+      | NotThere++-- | summariseModule finds the location of the source file for the given module.+-- This version always returns a ModuleNodeCompile node, it is useful for+-- --make mode.+summariseModule :: HscEnv+                -> HomeUnit+                -> M.Map (UnitId, FilePath) ModSummary+                -> IsBootInterface+                -> Located ModuleName+                -> PkgQual+                -> Maybe (StringBuffer, UTCTime)+                -> [ModuleName]+                -> IO SummariseResult+summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods =+  summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods+  where+    k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf+++-- | Like summariseModule but for interface files that we don't want to compile.+-- This version always returns a ModuleNodeFixed node.+summariseModuleInterface :: HscEnv+                        -> HomeUnit+                        -> IsBootInterface+                        -> Located ModuleName+                        -> PkgQual+                        -> [ModuleName]+                        -> IO SummariseResult+summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods =+  summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods+  where+    k _hsc_env loc mod = do+      -- The finder will return a path to the .hi-boot even if it doesn't actually+      -- exist. So check if it exists first before concluding it's there.+      does_exist <- doesFileExist (ml_hi_file loc)+      if does_exist+        then let key = moduleToMnk mod is_boot+             in return $ FoundHome (ModuleNodeFixed key loc)+        else return NotThere++++-- Summarise a module, and pick up source and timestamp.+summariseModuleDispatch+          :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module.+          -> HscEnv+          -> HomeUnit+          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import+          -> Located ModuleName -- Imported module to be summarised+          -> PkgQual+          -> [ModuleName]               -- Modules to exclude+          -> IO SummariseResult+++summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods+  | wanted_mod `elem` excl_mods+  = return NotThere+  | otherwise  = find_it+  where+    -- Temporarily change the currently active home unit so all operations+    -- happen relative to it+    hsc_env   = hscSetActiveHomeUnit home_unit hsc_env'++    find_it :: IO SummariseResult++    find_it = do+        found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg+        case found of+             Found location mod+                | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env ->+                        -- Home package+                         k hsc_env location mod+                | VirtUnit iud <- moduleUnit mod+                , not (isHomeModule home_unit mod)+                  -> return $ FoundInstantiation iud+                | otherwise -> return $ External (moduleUnitId mod)+             _ -> return NotThere+                        -- Not found+                        -- (If it is TRULY not found at all, we'll+                        -- error when we actually try to compile)+++-- | The continuation to summarise a home module if we want to find the source file+-- for it and potentially compile it.+summariseModuleWithSource+          :: HomeUnit+          -> M.Map (UnitId, FilePath) ModSummary+          -- ^ Map of old summaries+          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import+          -> Maybe (StringBuffer, UTCTime)+          -> HscEnv+          -> ModLocation+          -> Module+          -> IO SummariseResult+summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do+        -- Adjust location to point to the hs-boot source file,+        -- hi file, object file, when is_boot says so+        let src_fn = expectJust (ml_hs_file location)++                -- Check that it exists+                -- It might have been deleted since the Finder last found it+        maybe_h <- fileHashIfExists src_fn+        case maybe_h of+          -- This situation can also happen if we have found the .hs file but the+          -- .hs-boot file doesn't exist.+          Nothing -> return NotThere+          Just h  -> do+            fresult <- new_summary_cache_check location mod src_fn h+            return $ case fresult of+              Left err -> FoundHomeWithError (moduleUnitId mod, err)+              Right ms -> FoundHome (ModuleNodeCompile ms)++  where+    dflags    = hsc_dflags hsc_env+    new_summary_cache_check loc mod src_fn h+      | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map =++         -- check the hash on the source file, and+         -- return the cached summary if it hasn't changed.  If the+         -- file has changed then need to resummarise.+        case maybe_buf of+           Just (buf,_) ->+               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)+           Nothing    ->+               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h+      | otherwise = new_summary loc mod src_fn h++    new_summary :: ModLocation+                  -> Module+                  -> FilePath+                  -> Fingerprint+                  -> IO (Either DriverMessages ModSummary)+    new_summary location mod src_fn src_hash+      = runExceptT $ do+        preimps@PreprocessedImports {..}+            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP+            -- See multiHomeUnits_cpp2 test+            <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf++        -- NB: Despite the fact that is_boot is a top-level parameter, we+        -- don't actually know coming into this function what the HscSource+        -- of the module in question is.  This is because we may be processing+        -- this module because another module in the graph imported it: in this+        -- case, we know if it's a boot or not because of the {-# SOURCE #-}+        -- annotation, but we don't know if it's a signature or a regular+        -- module until we actually look it up on the filesystem.+        let hsc_src+              | is_boot == IsBoot           = HsBootFile+              | isHaskellSigFilename src_fn = HsigFile+              | otherwise                   = HsSrcFile++        when (pi_mod_name /= moduleName mod) $+                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                       $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)++        let instantiations = homeUnitInstantiations home_unit+        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $+            throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                   $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_hash = src_hash+            , nms_hsc_src = hsc_src+            , nms_location = location+            , nms_mod = mod+            , nms_preimps = preimps+            }++-- | Convenience named arguments for 'makeNewModSummary' only used to make+-- code more readable, not exported.+data MakeNewModSummary+  = MakeNewModSummary+      { nms_src_fn :: FilePath+      , nms_src_hash :: Fingerprint+      , nms_hsc_src :: HscSource+      , nms_location :: ModLocation+      , nms_mod :: Module+      , nms_preimps :: PreprocessedImports+      }++makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary+makeNewModSummary hsc_env MakeNewModSummary{..} = do+  let PreprocessedImports{..} = nms_preimps+  obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)+  dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)+  hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)+  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)++  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name+  (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps++  return $+        ModSummary+        { ms_mod = nms_mod+        , ms_hsc_src = nms_hsc_src+        , ms_location = nms_location+        , ms_hspp_file = pi_hspp_fn+        , ms_hspp_opts = pi_local_dflags+        , ms_hspp_buf  = Just pi_hspp_buf+        , ms_parsed_mod = Nothing+        , ms_srcimps = pi_srcimps+        , ms_textual_imps =+            ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) +++            ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs) +++            pi_theimps+        , ms_hs_hash = nms_src_hash+        , ms_iface_date = hi_timestamp+        , ms_hie_date = hie_timestamp+        , ms_obj_date = obj_timestamp+        , ms_dyn_obj_date = dyn_obj_timestamp+        }++data PreprocessedImports+  = PreprocessedImports+      { pi_local_dflags :: DynFlags+      , pi_srcimps  :: [Located ModuleName]+      , pi_theimps  :: [(ImportLevel, PkgQual, Located ModuleName)]+      , pi_hspp_fn  :: FilePath+      , pi_hspp_buf :: StringBuffer+      , pi_mod_name_loc :: SrcSpan+      , pi_mod_name :: ModuleName+      }++-- Preprocess the source file and get its imports+-- The pi_local_dflags contains the OPTIONS pragmas+getPreprocessedImports+    :: HscEnv+    -> FilePath+    -> Maybe Phase+    -> Maybe (StringBuffer, UTCTime)+    -- ^ optional source code buffer and modification time+    -> ExceptT DriverMessages IO PreprocessedImports+getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do+  (pi_local_dflags, pi_hspp_fn)+      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase+  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn+  (pi_srcimps', pi_theimps', L pi_mod_name_loc pi_mod_name)+      <- ExceptT $ do+          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 . getMessages) mimps)+  let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)+  let rn_imps = fmap (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn))+  let pi_srcimps = pi_srcimps'+  let pi_theimps = rn_imps pi_theimps'+  return PreprocessedImports {..}
compiler/GHC/Driver/Main.hs view
@@ -47,6 +47,7 @@     , initModDetails     , initWholeCoreBindings     , loadIfaceByteCode+    , loadIfaceByteCodeLazy     , hscMaybeWriteIface     , hscCompileCmmFile @@ -81,7 +82,7 @@     , hscRnImportDecls     , hscTcRnLookupRdrName     , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt-    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls+    , hscParseDeclsWithLocation, hscParsedDecls     , hscParseModuleWithLocation     , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType     , hscParseExpr@@ -104,6 +105,7 @@     , hscAddSptEntries     , writeInterfaceOnlyMode     , loadByteCode+    , genModDetails     ) where  import GHC.Prelude@@ -116,6 +118,7 @@ import GHC.Driver.Env import GHC.Driver.Env.KnotVars import GHC.Driver.Errors+import GHC.Driver.Messager import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)@@ -162,7 +165,7 @@  import GHC.IfaceToCore  ( typecheckIface, typecheckWholeCoreBindings ) -import GHC.Iface.Load   ( ifaceStats, writeIface, flagsToIfCompression )+import GHC.Iface.Load   ( ifaceStats, writeIface, flagsToIfCompression, getGhcPrimIface ) import GHC.Iface.Make import GHC.Iface.Recomp import GHC.Iface.Tidy@@ -187,7 +190,8 @@ import GHC.Core.LateCC.Types  -import GHC.CoreToStg.Prep+import GHC.CoreToStg.Prep( CorePrepPgmConfig, corePrepPgm, corePrepExpr )+import GHC.CoreToStg.AddImplicitBinds( addImplicitBinds ) import GHC.CoreToStg    ( coreToStg )  import GHC.Parser.Errors.Types@@ -202,7 +206,6 @@ import GHC.Stg.Syntax import GHC.Stg.Pipeline ( stg2stg, StgCgInfos ) -import GHC.Builtin.Utils import GHC.Builtin.Names  import qualified GHC.StgToCmm as StgToCmm ( codeGen )@@ -219,7 +222,6 @@ import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder-import GHC.Unit.External import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface@@ -244,7 +246,7 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Name-import GHC.Types.Name.Cache ( initNameCache )+import GHC.Types.Name.Cache ( newNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr import GHC.Types.TyThing@@ -295,12 +297,14 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) import GHC.Platform.Ways-import GHC.Stg.InferTags.TagSig (seqTagSig)+import GHC.Stg.EnforceEpt.TagSig (seqTagSig) import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Cmm.Config (CmmConfig) import Data.Bifunctor+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Home.PackageTable  {- ********************************************************************** %*                                                                      *@@ -309,25 +313,26 @@ %********************************************************************* -}  newHscEnv :: FilePath -> DynFlags -> IO HscEnv-newHscEnv top_dir dflags = newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) home_unit_graph+newHscEnv top_dir dflags = do+  hpt <- emptyHomePackageTable+  newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt)   where-    home_unit_graph = unitEnv_singleton+    home_unit_graph hpt = HUG.unitEnv_singleton                         (homeUnitId_ dflags)-                        (mkHomeUnitEnv dflags emptyHomePackageTable Nothing)+                        (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing)  newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do-    nc_var  <- initNameCache 'r' knownKeyNames+    nc_var  <- newNameCache     fc_var  <- initFinderCache     logger  <- initLogger     tmpfs   <- initTmpFs-    let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph+    let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup cur_unit home_unit_graph     unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)     llvm_config <- initLlvmConfigCache top_dir     return HscEnv { hsc_dflags         = top_dynflags                   , hsc_logger         = setLogFlags logger (initLogFlags top_dynflags)                   , hsc_targets        = []-                  , hsc_mod_graph      = emptyMG                   , hsc_IC             = emptyInteractiveContext dflags                   , hsc_NC             = nc_var                   , hsc_FC             = fc_var@@ -809,7 +814,6 @@ -}  -type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()  -- | Do the recompilation avoidance checks for both one-shot and --make modes -- This function is the *only* place in the compiler where we decide whether to@@ -826,7 +830,7 @@   = do     let         msg what = case mHscMessage of-          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary)+          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] (ModuleNodeCompile mod_summary))           Nothing -> return ()      -- First check to see if the interface file agrees with the@@ -841,7 +845,7 @@     case recomp_if_result of       OutOfDateItem reason mb_checked_iface -> do         msg $ NeedsRecompile reason-        return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface+        return $ HscRecompNeeded $ fmap mi_iface_hash mb_checked_iface       UpToDateItem checked_iface -> do         let lcl_dflags = ms_hspp_opts mod_summary         if | not (backendGeneratesCode (backend lcl_dflags)) -> do@@ -859,7 +863,7 @@            , xopt LangExt.TemplateHaskell lcl_dflags            -> do               msg $ needsRecompileBecause THWithJS-              return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface+              return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface             | otherwise -> do                -- Do need linkable@@ -915,7 +919,7 @@                    return $ HscUpToDate checked_iface $ linkable                  OutOfDateItem reason _ -> do                    msg $ NeedsRecompile reason-                   return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface+                   return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface  -- | Check that the .o files produced by compilation are already up-to-date -- or not.@@ -965,10 +969,8 @@     let       this_mod   = ms_mod mod_sum       if_date    = fromJust $ ms_iface_date mod_sum-    case mi_extra_decls iface of-      Just extra_decls -> do-          let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum)-                   (mi_foreign iface)+    case iface_core_bindings iface (ms_location mod_sum) of+      Just fi -> do           return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))       _ -> return $ outOfDateItemBecause MissingBytecode Nothing @@ -976,23 +978,21 @@ -- Compilers -------------------------------------------------------------- -add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> HscEnv+add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> IO () add_iface_to_hpt iface details =-  hscUpdateHPT $ \ hpt ->-    addToHpt hpt (moduleName (mi_module iface))-    (HomeModInfo iface details emptyHomeModInfoLinkable)+  hscInsertHPT (HomeModInfo iface details emptyHomeModInfoLinkable)  -- Knot tying!  See Note [Knot-tying typecheckIface] -- See Note [ModDetails and --make mode] initModDetails :: HscEnv -> ModIface -> IO ModDetails initModDetails hsc_env iface =   fixIO $ \details' -> do-    let !hsc_env' = add_iface_to_hpt iface details' hsc_env+    add_iface_to_hpt iface details' hsc_env     -- NB: This result is actually not that useful     -- in one-shot mode, since we're not going to do     -- any further typechecking.  It's much more useful     -- in make mode, since this HMI will go into the HPT.-    genModDetails hsc_env' iface+    genModDetails hsc_env iface  -- | Modify flags such that objects are compiled for the interpreter's way. -- This is necessary when building foreign objects for Template Haskell, since@@ -1018,15 +1018,15 @@ -- | Assemble 'WholeCoreBindings' if the interface contains Core bindings. iface_core_bindings :: ModIface -> ModLocation -> Maybe WholeCoreBindings iface_core_bindings iface wcb_mod_location =-  mi_extra_decls <&> \ wcb_bindings ->+  mi_simplified_core <&> \(IfaceSimplifiedCore bindings foreign') ->     WholeCoreBindings {-      wcb_bindings,+      wcb_bindings = bindings,       wcb_module = mi_module,       wcb_mod_location,-      wcb_foreign = mi_foreign+      wcb_foreign = foreign'     }   where-    ModIface {mi_module, mi_extra_decls, mi_foreign} = iface+    ModIface {mi_module, mi_simplified_core} = iface  -- | Return an 'IO' that hydrates Core bindings and compiles them to bytecode if -- the interface contains any, using the supplied type env for typechecking.@@ -1058,6 +1058,27 @@       time <- maybe getCurrentTime pure if_time       return $! Linkable time (mi_module iface) parts +loadIfaceByteCodeLazy ::+  HscEnv ->+  ModIface ->+  ModLocation ->+  TypeEnv ->+  IO (Maybe Linkable)+loadIfaceByteCodeLazy hsc_env iface location type_env =+  case iface_core_bindings iface location of+    Nothing -> return Nothing+    Just wcb -> do+      Just <$> compile wcb+  where+    compile decls = do+      ~(bcos, fos) <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls+      linkable $ NE.singleton (LazyBCOs bcos fos)++    linkable parts = do+      if_time <- modificationTimeIfExists (ml_hi_file location)+      time <- maybe getCurrentTime pure if_time+      return $!Linkable time (mi_module iface) parts+ -- | If the 'Linkable' contains Core bindings loaded from an interface, replace -- them with a lazy IO thunk that compiles them to bytecode and foreign objects, -- using the supplied environment for type checking.@@ -1074,23 +1095,29 @@ -- -- This is sound because generateByteCode just depends on things already loaded -- in the interface file.++-- TODO: We should just use loadIfaceByteCodeLazy instead of the two stage process with+-- loadByteCode and initWholeCoreBindings. The main reason it is like this is because+-- initWholeCoreBindings requires a ModDetails, which we don't have during recompilation+-- checking. We should modify recompilation checking to return a HomeModInfo directly.+ initWholeCoreBindings ::   HscEnv ->   ModIface ->   ModDetails ->   Linkable ->   IO Linkable-initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) =-  Linkable utc_time this_mod <$> mapM go uls+initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do+  Linkable utc_time this_mod <$> mapM (go hsc_env) uls   where-    go = \case+    go hsc_env' = \case       CoreBindings wcb -> do+        add_iface_to_hpt iface details hsc_env         ~(bco, fos) <- unsafeInterleaveIO $                        compileWholeCoreBindings hsc_env' type_env wcb         pure (LazyBCOs bco fos)       l -> pure l -    hsc_env' = add_iface_to_hpt iface details hsc_env     type_env = md_types details  -- | Hydrate interface Core bindings and compile them to bytecode.@@ -1214,12 +1241,17 @@   --   -- We usually desugar even when we are not generating code, otherwise we   -- would miss errors thrown by the desugaring (see #10600). The only-  -- exceptions are when the Module is Ghc.Prim or when it is not a-  -- HsSrcFile Module.-  mb_desugar <--      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile-      then Just <$> hscDesugar' (ms_location summary) tc_result-      else pure Nothing+  -- exception is when it is not a HsSrcFile module.+  mb_desugar <- if+    | hsc_src /= HsSrcFile       -> pure Nothing+    -- Desugar an empty ghc-prim:GHC.Prim module by filtering out all its+    -- bindings: the reason is that some of them are invalid (such as top-level+    -- unlifted ones like void# or proxy#) and cause HsToCore failures.+    --+    -- We still need to desugar *something* because the driver and the linkers+    -- expect a valid object file (.o) to be generated for this module.+    | ms_mod summary == gHC_PRIM -> Just <$> hscDesugar' (ms_location summary) (tc_result { tcg_binds = [] })+    | otherwise                  -> Just <$> hscDesugar' (ms_location summary) tc_result    -- Report the warnings from both typechecking and desugar together   w <- getDiagnostics@@ -1237,11 +1269,11 @@           (cg_guts, details) <-               liftIO $ hscTidy hsc_env simplified_guts -          let !partial_iface =+          !partial_iface <- liftIO $                 {-# SCC "GHC.Driver.Main.mkPartialIface" #-}                 -- This `force` saves 2M residency in test T10370                 -- See Note [Avoiding space leaks in toIface*] for details.-                force (mkPartialIface hsc_env (cg_binds cg_guts) details summary (tcg_import_decls tc_result) simplified_guts)+                fmap force (mkPartialIface hsc_env (cg_binds cg_guts) details summary (tcg_import_decls tc_result) simplified_guts)            return HscRecomp { hscs_guts = cg_guts,                              hscs_mod_location = ms_location summary,@@ -1264,7 +1296,11 @@            liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) -          return $ HscUpdate iface+          -- when compiling gHC_PRIM without generating code (e.g. with+          -- Haddock), we still want the virtual interface in the cache+          if ms_mod summary == gHC_PRIM+            then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env))+            else return $ HscUpdate iface         -- We are not generating code or writing an interface with simplified core so we can skip simplification@@ -1275,7 +1311,11 @@          liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) -        return $ HscUpdate iface+        -- when compiling gHC_PRIM without generating code (e.g. with+        -- Haddock), we still want the virtual interface in the cache+        if ms_mod summary == gHC_PRIM+          then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env))+          else return $ HscUpdate iface  {- Note [Writing interface files]@@ -1362,7 +1402,7 @@       --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic       --    interfaces stay in sync...       ---      let change = old_iface /= Just (mi_iface_hash (mi_final_exts iface))+      let change = old_iface /= Just (mi_iface_hash iface)        let dt = dynamicTooState dflags @@ -1435,46 +1475,7 @@     dumpIfaceStats hsc_env     return new_details ------------------------------------------------------------------ Progress displayers.--------------------------------------------------------------- -oneShotMsg :: Logger -> RecompileRequired -> IO ()-oneShotMsg logger recomp =-    case recomp of-        UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"-        NeedsRecompile _ -> return ()--batchMsg :: Messager-batchMsg = batchMsgWith (\_ _ _ _ -> empty)-batchMultiMsg :: Messager-batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node)))--batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager-batchMsgWith extra hsc_env_start mod_index recomp node =-      case recomp of-        UpToDate-          | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty-          | otherwise -> return ()-        NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of-          MustCompile            -> empty-          (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"-    where-        herald = case node of-                    LinkNode {} -> "Linking"-                    InstantiationNode {} -> "Instantiating"-                    ModuleNode {} -> "Compiling"-        hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start-        dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env-        state  = hsc_units hsc_env-        showMsg msg reason =-            compilationProgressMsg logger $-            (showModuleIndex mod_index <>-            msg <+> showModMsg dflags (recompileRequired recomp) node)-                <> extra hsc_env mod_index recomp node-                <> reason- -------------------------------------------------------------- -- Safe Haskell --------------------------------------------------------------@@ -1761,10 +1762,7 @@     lookup' :: Module -> Hsc (Maybe ModIface)     lookup' m = do         hsc_env <- getHscEnv-        hsc_eps <- liftIO $ hscEPS hsc_env-        let pkgIfaceT = eps_PIT hsc_eps-            hug       = hsc_HUG hsc_env-            iface     = lookupIfaceByModule hug pkgIfaceT m+        iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m         -- the 'lookupIfaceByModule' method will always fail when calling from GHCi         -- as the compiler hasn't filled in the various module tables         -- so we need to call 'getModuleInterface' to load from disk@@ -1919,7 +1917,7 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath                -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )                 -- ^ @Just f@ <=> _stub.c is f-hscGenHardCode hsc_env cgguts location output_filename = do+hscGenHardCode hsc_env cgguts mod_loc output_filename = do         let CgGuts{ cg_module   = this_mod,                     cg_binds    = core_binds,                     cg_ccs      = local_ccs@@ -1927,14 +1925,21 @@             dflags = hsc_dflags hsc_env             logger = hsc_logger hsc_env +        -------------------+        -- ADD IMPLICIT BINDINGS+        -- NB: we must feed mkImplicitBinds through corePrep too+        -- so that they are suitably cloned and eta-expanded+        let cp_pgm_cfg :: CorePrepPgmConfig+            cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env)+                                               (interactiveInScope $ hsc_IC hsc_env)+        binds_with_implicits <- addImplicitBinds cp_pgm_cfg mod_loc (cg_tycons cgguts) core_binds          --------------------        -- Insert late cost centres based on the provided flags.+        -- INSERT LATE COST CENTRES, based on the provided flags.         --         -- If -fprof-late-inline is enabled, we will skip adding CCs on any-        -- top-level bindings here (via shortcut in `addLateCostCenters`),-        -- since it will have already added a superset of the CCs we would add-        -- here.+        -- top-level bindings here (via shortcut in `addLateCostCenters`), since+        -- it will have already added a superset of the CCs we would add here.         let           late_cc_config :: LateCCConfig           late_cc_config =@@ -1953,21 +1958,21 @@               , lateCCConfig_env =                   LateCCEnv                     { lateCCEnv_module = this_mod-                    , lateCCEnv_file = fsLit <$> ml_hs_file location+                    , lateCCEnv_file = fsLit <$> ml_hs_file mod_loc                     , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags                     , lateCCEnv_collectCCs = True                     }               }          (late_cc_binds, late_cc_state) <--          addLateCostCenters logger late_cc_config core_binds+          addLateCostCenters logger late_cc_config binds_with_implicits          when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $           putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr late_cc_binds))          --------------------        -- Run late plugins-        -- This is the last use of the ModGuts in a compilation.+        -- RUN LATE PLUGINS+        -- This is the last use of the CgGuts in a compilation.         -- From now on, we just use the bits we need.         ( CgGuts             { cg_tycons        = tycons,@@ -1975,7 +1980,7 @@               cg_foreign_files = foreign_files,               cg_dep_pkgs      = dependencies,               cg_spt_entries   = spt_entries,-              cg_binds         = late_binds,+              cg_binds         = binds_to_prep,               cg_ccs           = late_local_ccs             }           , _@@ -1999,22 +2004,15 @@           tmpfs  = hsc_tmpfs hsc_env           llvm_config = hsc_llvm_config hsc_env           profile = targetProfile dflags-          data_tycons = filter isDataTyCon tycons-          -- cg_tycons includes newtypes, for the benefit of External Core,-          -- but we don't generate any code for newtypes --         -------------------         -- PREPARE FOR CODE GENERATION         -- Do saturation and convert to A-normal form-        (prepd_binds) <- {-# SCC "CorePrep" #-} do-          cp_cfg <- initCorePrepConfig hsc_env-          corePrepPgm-            (hsc_logger hsc_env)-            cp_cfg-            (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))-            this_mod location late_binds data_tycons+        cp_cfg <- initCorePrepConfig hsc_env+        (prepd_binds) <- {-# SCC "CorePrep" #-}+                         corePrepPgm+                           (hsc_logger hsc_env) cp_cfg cp_pgm_cfg+                           this_mod binds_to_prep          -----------------  Convert to STG ------------------         (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)@@ -2027,7 +2025,7 @@                         c `seqList`                         d `seqList`                         (seqEltsUFM (seqTagSig) tag_env))-                   (myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) False this_mod location prepd_binds)+                   (myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) False this_mod mod_loc prepd_binds)          let (stg_binds,_stg_deps) = unzip stg_binds_with_deps @@ -2075,7 +2073,7 @@             _          ->               do               cmms <- {-# SCC "StgToCmm" #-}-                doCodeGen hsc_env this_mod denv data_tycons+                doCodeGen hsc_env this_mod denv tycons                 cost_centre_info                 stg_binds @@ -2096,7 +2094,7 @@                (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)                   <- {-# SCC "codeOutput" #-}-                    codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location+                    codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename mod_loc                     foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1               return  ( output_filename, stub_c_exists, foreign_fps                       , Just stg_cg_infos, Just cmm_cg_infos)@@ -2120,7 +2118,7 @@                -> CgInteractiveGuts                -> ModLocation                -> IO (Maybe FilePath, CompiledByteCode) -- ^ .c stub path (if any) and ByteCode-hscInteractive hsc_env cgguts location = do+hscInteractive hsc_env cgguts mod_loc = do     let dflags = hsc_dflags hsc_env     let logger = hsc_logger hsc_env     let tmpfs  = hsc_tmpfs hsc_env@@ -2133,35 +2131,35 @@                cgi_modBreaks = mod_breaks,                cgi_spt_entries = spt_entries } = cgguts -        data_tycons = filter isDataTyCon tycons-        -- cg_tycons includes newtypes, for the benefit of External Core,-        -- but we don't generate any code for newtypes+    -------------------+    -- ADD IMPLICIT BINDINGS+    let cp_pgm_cfg :: CorePrepPgmConfig+        cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env)+                                           (interactiveInScope $ hsc_IC hsc_env)+    binds_to_prep <- addImplicitBinds cp_pgm_cfg mod_loc tycons core_binds      -------------------     -- PREPARE FOR CODE GENERATION     -- Do saturation and convert to A-normal form-    prepd_binds <- {-# SCC "CorePrep" #-} do-      cp_cfg <- initCorePrepConfig hsc_env-      corePrepPgm-        (hsc_logger hsc_env)-        cp_cfg-        (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))-        this_mod location core_binds data_tycons+    cp_cfg <- initCorePrepConfig hsc_env+    prepd_binds <- {-# SCC "CorePrep" #-}+                   corePrepPgm (hsc_logger hsc_env) cp_cfg cp_pgm_cfg+                               this_mod binds_to_prep      -- The stg cg info only provides a runtime benfit, but is not requires so we just     -- omit it here     (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)       <- {-# SCC "CoreToStg" #-}-          myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) True this_mod location prepd_binds+          myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) True this_mod mod_loc prepd_binds      let (stg_binds,_stg_deps) = unzip stg_binds_with_deps      -----------------  Generate byte code -------------------    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks spt_entries+    comp_bc <- byteCodeGen hsc_env this_mod stg_binds tycons mod_breaks spt_entries      ------------------ Create f-x-dynamic C-side stuff -----     (_istub_h_exists, istub_c_exists)-        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs+        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod mod_loc foreign_stubs     return (istub_c_exists, comp_bc)  -- | Compile Core bindings and foreign inputs that were loaded from an@@ -2288,7 +2286,7 @@          -- Note we produce a 'Stream' of CmmGroups, so that the          -- backend can be run incrementally.  Otherwise it generates all          -- the C-- up front, which has a significant space cost.-doCodeGen hsc_env this_mod denv data_tycons+doCodeGen hsc_env this_mod denv tycons               cost_centre_info stg_binds_w_fvs = do     let dflags     = hsc_dflags hsc_env         logger     = hsc_logger hsc_env@@ -2307,7 +2305,7 @@     let cmm_stream :: CgStream CmmGroup (ModuleLFInfos, DetUniqFM)         -- See Note [Forcing of stg_binds]         cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}-            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs+            stg_to_cmm dflags this_mod denv tycons cost_centre_info stg_binds_w_fvs          -- codegen consumes a stream of CmmGroup, and produces a new         -- stream of CmmGroup (not necessarily synchronised: one@@ -2458,12 +2456,6 @@    return $ Just (ids, hval, fix_env) --- | Compile a decls-hscDecls :: HscEnv-         -> String -- ^ The statement-         -> IO ([TyThing], InteractiveContext)-hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1- hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO (HsModule GhcPs) hscParseModuleWithLocation hsc_env source line_num str = do     L _ mod <-@@ -2476,18 +2468,6 @@   HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str   return decls --- | Compile a decls-hscDeclsWithLocation :: HscEnv-                     -> String -- ^ The statement-                     -> String -- ^ The source-                     -> Int    -- ^ Starting line-                     -> IO ([TyThing], InteractiveContext)-hscDeclsWithLocation hsc_env str source linenumber = do-    L _ (HsModule{ hsmodDecls = decls }) <--      runInteractiveHsc hsc_env $-        hscParseThingWithLocation source linenumber parseModule str-    hscParsedDecls hsc_env decls- hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext) hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do     hsc_env <- getHscEnv@@ -2819,8 +2799,7 @@       (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $         Linkable bco_time this_mod $ NE.singleton $ BCOs bcos       {- Get the HValue for the root -}-      return (expectJust "hscCompileCoreExpr'"-         $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed)+      return (expectJust $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed)   @@ -2904,7 +2883,7 @@     jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots    -- look up "id_sym" closure and create a StablePtr (HValue) from it-  href <- lookupClosure interp (unpackFS id_sym) >>= \case+  href <- lookupClosure interp (IFaststringSymbol id_sym) >>= \case     Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym)     Just r  -> pure r @@ -2931,18 +2910,6 @@     logDumpMsg logger "Interface statistics" (ifaceStats eps)  -{- **********************************************************************-%*                                                                      *-        Progress Messages: Module i of n-%*                                                                      *-%********************************************************************* -}--showModuleIndex :: (Int, Int) -> SDoc-showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "-  where-    -- compute the length of x > 0 in base 10-    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)-    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr  writeInterfaceOnlyMode :: DynFlags -> Bool writeInterfaceOnlyMode dflags =
compiler/GHC/Driver/Make.hs view
@@ -1,3042 +1,1935 @@ {-# LANGUAGE NondecreasingIndentation #-}--{-# LANGUAGE GADTs #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE RecordWildCards #-}---- ----------------------------------------------------------------------------------- (c) The University of Glasgow, 2011------ This module implements multi-module compilation, and is used--- by --make and GHCi.------ ------------------------------------------------------------------------------module GHC.Driver.Make (-        depanal, depanalE, depanalPartial, checkHomeUnitsClosed,-        load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,-        instantiationNodes,--        downsweep,--        topSortModuleGraph,--        ms_home_srcimps, ms_home_imps,--        summariseModule,-        SummariseResult(..),-        summariseFile,-        hscSourceToIsBoot,-        findExtraSigImports,-        implicitRequirementsShallow,--        noModError, cyclicModuleErr,-        SummaryNode,-        IsBootInterface(..), mkNodeKey,--        ModNodeKey, ModNodeKeyWithUid(..),-        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith-        ) where--import GHC.Prelude-import GHC.Platform--import GHC.Tc.Utils.Backpack-import GHC.Tc.Utils.Monad  ( initIfaceCheck, concatMapM )--import GHC.Runtime.Interpreter-import qualified GHC.Linker.Loader as Linker-import GHC.Linker.Types--import GHC.Platform.Ways--import GHC.Driver.Config.Finder (initFinderOpts)-import GHC.Driver.Config.Parser (initParserOpts)-import GHC.Driver.Config.Diagnostic-import GHC.Driver.Phases-import GHC.Driver.Pipeline-import GHC.Driver.Session-import GHC.Driver.DynFlags (ReexportedModule(..))-import GHC.Driver.Backend-import GHC.Driver.Monad-import GHC.Driver.Env-import GHC.Driver.Errors-import GHC.Driver.Errors.Types-import GHC.Driver.Main-import GHC.Driver.MakeSem--import GHC.Parser.Header-import GHC.ByteCode.Types--import GHC.Iface.Load      ( cannotFindModule )-import GHC.IfaceToCore     ( typecheckIface )-import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )--import GHC.Data.Bag        ( listToBag )-import GHC.Data.Graph.Directed-import GHC.Data.FastString-import GHC.Data.Maybe      ( expectJust )-import GHC.Data.OsPath     ( unsafeEncodeUtf )-import GHC.Data.StringBuffer-import qualified GHC.LanguageExtensions as LangExt--import GHC.Utils.Exception ( throwIO, SomeAsyncException )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Misc-import GHC.Utils.Error-import GHC.Utils.Logger-import GHC.Utils.Fingerprint-import GHC.Utils.TmpFs--import GHC.Types.Basic-import GHC.Types.Error-import GHC.Types.Target-import GHC.Types.SourceFile-import GHC.Types.SourceError-import GHC.Types.SrcLoc-import GHC.Types.Unique.Map-import GHC.Types.PkgQual--import GHC.Unit-import GHC.Unit.Env-import GHC.Unit.Finder-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Graph-import GHC.Unit.Home.ModInfo-import GHC.Unit.Module.ModDetails--import Data.Either ( rights, partitionEithers, lefts )-import qualified Data.Map as Map-import qualified Data.Set as Set--import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )-import qualified GHC.Conc as CC-import Control.Concurrent.MVar-import Control.Monad-import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )-import qualified Control.Monad.Catch as MC-import Data.IORef-import Data.Maybe-import Data.Time-import Data.List (sortOn)-import Data.Bifunctor (first)-import System.Directory-import System.FilePath-import System.IO        ( fixIO )--import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import GHC.Driver.Pipeline.LogQueue-import qualified Data.Map.Strict as M-import GHC.Types.TypeEnv-import Control.Monad.Trans.State.Lazy-import Control.Monad.Trans.Class-import GHC.Driver.Env.KnotVars-import Control.Concurrent.STM-import Control.Monad.Trans.Maybe-import GHC.Runtime.Loader-import GHC.Rename.Names-import GHC.Utils.Constants-import GHC.Types.Unique.DFM (udfmRestrictKeysSet)-import GHC.Types.Unique-import GHC.Iface.Errors.Types--import qualified GHC.Data.Word64Set as W---- -------------------------------------------------------------------------------- Loading the program---- | Perform a dependency analysis starting from the current targets--- and update the session with the new module graph.------ Dependency analysis entails parsing the @import@ directives and may--- therefore require running certain preprocessors.------ Note that each 'ModSummary' in the module graph caches its 'DynFlags'.--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want--- changes to the 'DynFlags' to take effect you need to call this function--- again.--- In case of errors, just throw them.----depanal :: GhcMonad m =>-           [ModuleName]  -- ^ excluded modules-        -> Bool          -- ^ allow duplicate roots-        -> m ModuleGraph-depanal excluded_mods allow_dup_roots = do-    (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots-    if isEmptyMessages errs-      then pure mod_graph-      else throwErrors (fmap GhcDriverMessage errs)---- | Perform dependency analysis like in 'depanal'.--- In case of errors, the errors and an empty module graph are returned.-depanalE :: GhcMonad m =>     -- New for #17459-            [ModuleName]      -- ^ excluded modules-            -> Bool           -- ^ allow duplicate roots-            -> m (DriverMessages, ModuleGraph)-depanalE excluded_mods allow_dup_roots = do-    hsc_env <- getSession-    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots-    if isEmptyMessages errs-      then do-        hsc_env <- getSession-        let one_unit_messages get_mod_errs k hue = do-              errs <- get_mod_errs-              unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph--              let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph-                  unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph---              return $ errs `unionMessages` unused_home_mod_err-                          `unionMessages` unused_pkg_err-                          `unionMessages` unknown_module_err--        all_errs <- liftIO $ unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)-        logDiagnostics (GhcDriverMessage <$> all_errs)-        setSession hsc_env { hsc_mod_graph = mod_graph }-        pure (emptyMessages, mod_graph)-      else do-        -- We don't have a complete module dependency graph,-        -- The graph may be disconnected and is unusable.-        setSession hsc_env { hsc_mod_graph = emptyMG }-        pure (errs, emptyMG)----- | Perform dependency analysis like 'depanal' but return a partial module--- graph even in the face of problems with some modules.------ Modules which have parse errors in the module header, failing--- preprocessors or other issues preventing them from being summarised will--- simply be absent from the returned module graph.------ Unlike 'depanal' this function will not update 'hsc_mod_graph' with the--- new module graph.-depanalPartial-    :: GhcMonad m-    => [ModuleName]  -- ^ excluded modules-    -> Bool          -- ^ allow duplicate roots-    -> m (DriverMessages, ModuleGraph)-    -- ^ possibly empty 'Bag' of errors and a module graph.-depanalPartial excluded_mods allow_dup_roots = do-  hsc_env <- getSession-  let-         targets = hsc_targets hsc_env-         old_graph = hsc_mod_graph hsc_env-         logger  = hsc_logger hsc_env--  withTiming logger (text "Chasing dependencies") (const ()) $ do-    liftIO $ debugTraceMsg logger 2 (hcat [-              text "Chasing modules from: ",-              hcat (punctuate comma (map pprTarget targets))])--    -- Home package modules may have been moved or deleted, and new-    -- source files may have appeared in the home package that shadow-    -- external package modules, so we have to discard the existing-    -- cached finder data.-    liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)--    (errs, graph_nodes) <- liftIO $ downsweep-      hsc_env (mgModSummaries old_graph)-      excluded_mods allow_dup_roots-    let-      mod_graph = mkModuleGraph graph_nodes-    return (unionManyMessages errs, mod_graph)---- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.--- These are used to represent the type checking that is done after--- all the free holes (sigs in current package) relevant to that instantiation--- are compiled. This is necessary to catch some instantiation errors.------ In the future, perhaps more of the work of instantiation could be moved here,--- instead of shoved in with the module compilation nodes. That could simplify--- backpack, and maybe hs-boot too.-instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]-instantiationNodes uid unit_state = InstantiationNode uid <$> iuids_to_check-  where-    iuids_to_check :: [InstantiatedUnit]-    iuids_to_check =-      nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state)-     where-      goUnitId uid =-        [ recur-        | VirtUnit indef <- [uid]-        , inst <- instUnitInsts indef-        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst-        ]---- The linking plan for each module. If we need to do linking for a home unit--- then this function returns a graph node which depends on all the modules in the home unit.---- At the moment nothing can depend on these LinkNodes.-linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)-linkNodes summaries uid hue =-  let dflags = homeUnitEnv_dflags hue-      ofile = outputFile_ dflags--      unit_nodes :: [NodeKey]-      unit_nodes = map mkNodeKey (filter ((== uid) . moduleGraphNodeUnitId) summaries)-  -- Issue a warning for the confusing case where the user-  -- said '-o foo' but we're not going to do any linking.-  -- We attempt linking if either (a) one of the modules is-  -- called Main, or (b) the user said -no-hs-main, indicating-  -- that main() is going to come from somewhere else.-  ---      no_hs_main = gopt Opt_NoHsMain dflags--      main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes--      do_linking =  main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib--  in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking ->-            Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))-        -- This should be an error, not a warning (#10895).-        | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))-        | otherwise  -> Nothing---- Note [Missing home modules]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Sometimes we don't want GHC to process modules that weren't specified as--- explicit targets. For example, cabal may want to enable this warning--- when building a library, so that GHC warns the user about modules listed--- neither in `exposed-modules` nor in `other-modules`.------ Here "home module" means a module that doesn't come from another package.------ For example, if GHC is invoked with modules "A" and "B" as targets,--- but "A" imports some other module "C", then GHC will issue a warning--- about module "C" not being listed in the command line.------ The warning in enabled by `-Wmissing-home-modules`. See #13129-warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages-warnMissingHomeModules dflags targets mod_graph =-    if null missing-      then emptyMessages-      else warn-  where-    diag_opts = initDiagOpts dflags--    -- We need to be careful to handle the case where (possibly-    -- path-qualified) filenames (aka 'TargetFile') rather than module-    -- names are being passed on the GHC command-line.-    ---    -- For instance, `ghc --make src-exe/Main.hs` and-    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.-    -- Note also that we can't always infer the associated module name-    -- directly from the filename argument.  See #13727.-    is_known_module mod =-      is_module_target mod-      ||-      maybe False is_file_target (ml_hs_file (ms_location mod))--    is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets--    is_file_target file = Set.member (withoutExt file) file_targets--    file_targets = Set.fromList (mapMaybe file_target targets)--    file_target Target {targetId} =-      case targetId of-        TargetModule _ -> Nothing-        TargetFile file _ ->-          Just (withoutExt (augmentByWorkingDirectory dflags file))--    mod_targets = Set.fromList (mod_target <$> targets)--    mod_target Target {targetUnitId, targetId} =-      case targetId of-        TargetModule name -> (name, targetUnitId)-        TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId)--    withoutExt = fst . splitExtension--    missing = map (moduleName . ms_mod) $-      filter (not . is_known_module) $-        (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)-                (mgModSummaries mod_graph))--    warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan-                         $ DriverMissingHomeModules (homeUnitId_ dflags) missing (checkBuildingCabalPackage dflags)---- Check that any modules we want to reexport or hide are actually in the package.-warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages-warnUnknownModules hsc_env dflags mod_graph = do-  reexported_warns <- filterM check_reexport reexported_mods-  return $ final_msgs hidden_warns reexported_warns-  where-    diag_opts = initDiagOpts dflags--    unit_mods = Set.fromList (map ms_mod_name-                  (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)-                       (mgModSummaries mod_graph)))--    reexported_mods = reexportedModules dflags-    hidden_mods     = hiddenModules dflags--    hidden_warns = hidden_mods `Set.difference` unit_mods--    lookupModule mn = findImportedModule hsc_env mn NoPkgQual--    check_reexport mn = do-      fr <- lookupModule (reexportFrom mn)-      case fr of-        Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)-        _ -> return True---    warn diagnostic = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan-                         $ diagnostic--    final_msgs hidden_warns reexported_warns-          =-        unionManyMessages $-          [warn (DriverUnknownHiddenModules (homeUnitId_ dflags) (Set.toList hidden_warns)) | not (Set.null hidden_warns)]-          ++ [warn (DriverUnknownReexportedModules (homeUnitId_ dflags) reexported_warns) | not (null reexported_warns)]---- | Describes which modules of the module graph need to be loaded.-data LoadHowMuch-   = LoadAllTargets-     -- ^ Load all targets and its dependencies.-   | LoadUpTo HomeUnitModule-     -- ^ Load only the given module and its dependencies.-   | LoadDependenciesOf HomeUnitModule-     -- ^ Load only the dependencies of the given module, but not the module-     -- itself.--{--Note [Caching HomeModInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~--API clients who call `load` like to cache the HomeModInfo in memory between-calls to this function. In the old days, this cache was a simple MVar which stored-a HomePackageTable. This was insufficient, as the interface files for boot modules-were not recorded in the cache. In the less old days, the cache was returned at the-end of load, and supplied at the start of load, however, this was not sufficient-because it didn't account for the possibility of exceptions such as SIGINT (#20780).--So now, in the current day, we have this ModIfaceCache abstraction which-can incrementally be updated during the process of upsweep. This allows us-to store interface files for boot modules in an exception-safe way.--When the final version of an interface file is completed then it is placed into-the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache.--Note that because we only store the ModIface and Linkable in the ModIfaceCache,-hydration and rehydration is totally irrelevant, and we just store the CachedIface as-soon as it is completed.---}----- Abstract interface to a cache of HomeModInfo--- See Note [Caching HomeModInfo]-data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface]-                                   , iface_addToCache :: CachedIface -> IO () }--addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()-addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l)--data CachedIface = CachedIface { cached_modiface :: !ModIface-                               , cached_linkable :: !HomeModLinkable }--instance Outputable CachedIface where-  ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln]--noIfaceCache :: Maybe ModIfaceCache-noIfaceCache = Nothing--newIfaceCache :: IO ModIfaceCache-newIfaceCache = do-  ioref <- newIORef []-  return $-    ModIfaceCache-      { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c))-      , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ()))-      }------- | Try to load the program.  See 'LoadHowMuch' for the different modes.------ This function implements the core of GHC's @--make@ mode.  It preprocesses,--- compiles and loads the specified modules, avoiding re-compilation wherever--- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling--- and loading may result in files being created on disk.------ Calls the 'defaultWarnErrLogger' after each compiling each module, whether--- successful or not.------ If errors are encountered during dependency analysis, the module `depanalE`--- returns together with the errors an empty ModuleGraph.--- After processing this empty ModuleGraph, the errors of depanalE are thrown.--- All other errors are reported using the 'defaultWarnErrLogger'.--load :: GhcMonad f => LoadHowMuch -> f SuccessFlag-load how_much = loadWithCache noIfaceCache mkUnknownDiagnostic how_much--mkBatchMsg :: HscEnv -> Messager-mkBatchMsg hsc_env =-  if length (hsc_all_home_unit_ids hsc_env) > 1-    -- This also displays what unit each module is from.-    then batchMultiMsg-    else batchMsg--type AnyGhcDiagnostic = UnknownDiagnostic (DiagnosticOpts GhcMessage)--loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how to cache interfaces as we create them.-                            -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user.-                                                                -- If you are using the GHC API you can use this to override how messages-                                                                -- created during 'loadWithCache' are displayed to the user.-                            -> LoadHowMuch -- ^ How much `loadWithCache` should load-                            -> m SuccessFlag-loadWithCache cache diag_wrapper how_much = do-    (errs, mod_graph) <- depanalE [] False                        -- #17459-    msg <- mkBatchMsg <$> getSession-    success <- load' cache how_much diag_wrapper (Just msg) mod_graph-    if isEmptyMessages errs-      then pure success-      else throwErrors (fmap GhcDriverMessage errs)---- Note [Unused packages]--- ~~~~~~~~~~~~~~~~~~~~~~--- Cabal passes `--package-id` flag for each direct dependency. But GHC--- loads them lazily, so when compilation is done, we have a list of all--- actually loaded packages. All the packages, specified on command line,--- but never loaded, are probably unused dependencies.--warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages-warnUnusedPackages us dflags mod_graph =-    let diag_opts = initDiagOpts dflags--        home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)--    -- Only need non-source imports here because SOURCE imports are always HPT-        loadedPackages = concat $-          mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)-            $ concatMap ms_imps home_mod_sum--        any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum--        used_args = Set.fromList (map unitId loadedPackages)-                      `Set.union` Set.fromList [ primUnitId |  any_import_ghc_prim ]--        resolve (u,mflag) = do-                  -- The units which we depend on via the command line explicitly-                  flag <- mflag-                  -- Which we can find the UnitInfo for (should be all of them)-                  ui <- lookupUnit us u-                  -- Which are not explicitly used-                  guard (Set.notMember (unitId ui) used_args)-                  return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)--        unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us)--        warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)--    in if null unusedArgs-        then emptyMessages-        else warn---- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any--- path from module to its boot file.-data ModuleGraphNodeWithBootFile-  = ModuleGraphNodeWithBootFile-     ModuleGraphNode-       -- ^ The module itself (not the hs-boot module)-     [NodeKey]-       -- ^ The modules in between the module and its hs-boot file,-       -- not including the hs-boot file itself.---instance Outputable ModuleGraphNodeWithBootFile where-  ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps---- | A 'BuildPlan' is the result of attempting to linearise a single strongly-connected--- component of the module graph.-data BuildPlan-  -- | A simple, single module all alone (which *might* have an hs-boot file, if it isn't part of a cycle)-  = SingleModule ModuleGraphNode-  -- | A resolved cycle, linearised by hs-boot files-  | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]-  -- | An actual cycle, which wasn't resolved by hs-boot files-  | UnresolvedCycle [ModuleGraphNode]--instance Outputable BuildPlan where-  ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)-  ppr (ResolvedCycle mgn)   = text "ResolvedCycle:" <+> ppr mgn-  ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn----- Just used for an assertion-countMods :: BuildPlan -> Int-countMods (SingleModule _) = 1-countMods (ResolvedCycle ns) = length ns-countMods (UnresolvedCycle ns) = length ns---- See Note [Upsweep] for a high-level description.-createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]-createBuildPlan mod_graph maybe_top_mod =-    let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles-        cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod--        -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.-        build_plan :: [BuildPlan]-        build_plan-          -- Fast path, if there are no boot modules just do a normal toposort-          | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod-          | otherwise = toBuildPlan cycle_mod_graph []--        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]-        toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)-        toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)-        -- Interesting case-        toBuildPlan ((CyclicSCC nodes):sccs) mgn =-          let acyclic = collapseAcyclic (topSortWithBoot mgn)-              -- Now perform another toposort but just with these nodes and relevant hs-boot files.-              -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.-              mresolved_cycle = collapseSCC (topSortWithBoot nodes)-          in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []--        (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)-        trans_deps_map = allReachable mg (mkNodeKey . node_payload)-        -- Compute the intermediate modules between a file and its hs-boot file.-        -- See Step 2a in Note [Upsweep]-        boot_path mn uid =-          map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $-          -- Don't include the boot module itself-          Set.delete (NodeKey_Module (key IsBoot))  $-          -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are-          -- the transitive dependencies of the non-boot file which transitively depend-          -- on the boot file.-          Set.filter (\nk -> nodeKeyUnitId nk == uid  -- Cheap test-                              && (NodeKey_Module (key IsBoot)) `Set.member` expectJust "dep_on_boot" (M.lookup nk trans_deps_map)) $-          expectJust "not_boot_dep" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)-          where-            key ib = ModNodeKeyWithUid (GWIB mn ib) uid---        -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists-        boot_modules = mkModuleEnv-          [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]--        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]-        select_boot_modules = mapMaybe (fmap fst . get_boot_module)--        get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])-        get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing--        -- Any cycles should be resolved now-        collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]-        -- Must be at least two nodes, as we were in a cycle-        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2]-        collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes)-        -- Cyclic-        collapseSCC nodes = Left (flattenSCCs nodes)--        toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile-        toNodeWithBoot mn =-          case get_boot_module mn of-            -- The node doesn't have a boot file-            Nothing -> Left mn-            -- The node does have a boot file-            Just path -> Right (ModuleGraphNodeWithBootFile mn (map mkNodeKey (snd path)))--        -- The toposort and accumulation of acyclic modules is solely to pick-up-        -- hs-boot files which are **not** part of cycles.-        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]-        collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes-        collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes-        collapseAcyclic [] = []--        topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing---  in--    assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))-              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))])-              build_plan--mkWorkerLimit :: DynFlags -> IO WorkerLimit-mkWorkerLimit dflags =-  case parMakeCount dflags of-    Nothing -> pure $ num_procs 1-    Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h))-    Just ParMakeNumProcessors -> num_procs <$> getNumProcessors-    Just (ParMakeThisMany n) -> pure $ num_procs n-  where-    num_procs x = NumProcessorsLimit (max 1 x)--isWorkerLimitSequential :: WorkerLimit -> Bool-isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1-isWorkerLimitSequential (JSemLimit {})         = False---- | This describes what we use to limit the number of jobs, either we limit it--- ourselves to a specific number or we have an external parallelism semaphore--- limit it for us.-data WorkerLimit-  = NumProcessorsLimit Int-  | JSemLimit-    SemaphoreName-      -- ^ Semaphore name to use-  deriving Eq---- | Generalized version of 'load' which also supports a custom--- 'Messager' (for reporting progress) and 'ModuleGraph' (generally--- produced by calling 'depanal'.-load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag-load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do-    -- In normal usage plugins are initialised already by ghc/Main.hs this is protective-    -- for any client who might interact with GHC via load'.-    -- See Note [Timing of plugin initialization]-    initializeSessionPlugins-    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }-    guessOutputFile-    hsc_env <- getSession--    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let interp = hscInterp hsc_env--    -- The "bad" boot modules are the ones for which we have-    -- B.hs-boot in the module graph, but no B.hs-    -- The downsweep should have ensured this does not happen-    -- (see msDeps)-    let all_home_mods =-          Set.fromList [ Module (ms_unitid s) (ms_mod_name s)-                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]-    -- TODO: Figure out what the correct form of this assert is. It's violated-    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot-    -- 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 ()--    -- check that the module given in HowMuch actually exists, otherwise-    -- topSortModuleGraph will bomb later.-    let checkHowMuch (LoadUpTo m)           = checkMod m-        checkHowMuch (LoadDependenciesOf m) = checkMod m-        checkHowMuch _ = id--        checkMod m and_then-            | m `Set.member` all_home_mods = and_then-            | otherwise = do-                    throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan-                                  $ GhcDriverMessage-                                  $ DriverModuleNotFound (moduleName m)--    checkHowMuch how_much $ do--    -- mg2_with_srcimps drops the hi-boot nodes, returning a-    -- graph with cycles. It is just used for warning about unnecessary source imports.-    let mg2_with_srcimps :: [SCC ModuleGraphNode]-        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing--    -- If we can determine that any of the {-# SOURCE #-} imports-    -- are definitely unnecessary, then emit a warning.-    warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)--    let maybe_top_mod = case how_much of-                          LoadUpTo m           -> Just m-                          LoadDependenciesOf m -> Just m-                          _                    -> Nothing--        build_plan = createBuildPlan mod_graph maybe_top_mod---    cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache-    let-        -- prune the HPT so everything is not retained when doing an-        -- upsweep.-        !pruned_cache = pruneCache cache-                            (flattenSCCs (filterToposortToModules  mg2_with_srcimps))---    -- before we unload anything, make sure we don't leave an old-    -- interactive context around pointing to dead bindings.  Also,-    -- write an empty HPT to allow the old HPT to be GC'd.--    let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }-    setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env-    hsc_env <- getSession--    -- Unload everything-    liftIO $ unload interp hsc_env--    liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")-                                    2 (ppr build_plan))--    worker_limit <- liftIO $ mkWorkerLimit dflags--    (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do-      hsc_env <- getSession-      liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan-    modifySession (addDepsToHscEnv new_deps)-    case upsweep_ok of-      Failed -> loadFinish upsweep_ok-      Succeeded -> do-          liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")-          loadFinish upsweep_ok------ | Finish up after a load.-loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag--- Empty the interactive context and set the module context to the topmost--- newly loaded module, or the Prelude if none were loaded.-loadFinish all_ok-  = do modifySession discardIC-       return all_ok----- | If there is no -o option, guess the name of target executable--- by using top-level source file name as a base.-guessOutputFile :: GhcMonad m => m ()-guessOutputFile = modifySession $ \env ->-    -- Force mod_graph to avoid leaking env-    let !mod_graph = hsc_mod_graph env-        new_home_graph =-          flip unitEnv_map (hsc_HUG env) $ \hue ->-            let dflags = homeUnitEnv_dflags hue-                platform = targetPlatform dflags-                mainModuleSrcPath :: Maybe String-                mainModuleSrcPath = do-                  ms <- mgLookupModule mod_graph (mainModIs hue)-                  ml_hs_file (ms_location ms)-                name = fmap dropExtension mainModuleSrcPath--                -- MP: This exception is quite sensitive to being forced, if you-                -- force it here then the error message is different because it gets-                -- caught by a different error handler than the test (T9930fail) expects.-                -- Putting an exception into DynFlags is probably not a great design but-                -- I'll write this comment rather than more eagerly force the exception.-                name_exe = do-                  -- 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' <- case platformArchOS platform of-                             ArchOS _ OSMinGW32  -> fmap (<.> "exe") name-                             ArchOS ArchWasm32 _ -> fmap (<.> "wasm") name-                             _ -> name-                 mainModuleSrcPath' <- mainModuleSrcPath-                 -- #9930: don't clobber input files (unless they ask for it)-                 if name' == mainModuleSrcPath'-                   then throwGhcException . UsageError $-                        "default output name would overwrite the input file; " ++-                        "must specify -o explicitly"-                   else Just name'-            in-              case outputFile_ dflags of-                Just _ -> hue-                Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }-    in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }---- ----------------------------------------------------------------------------------- | Prune the HomePackageTable------ Before doing an upsweep, we can throw away:------   - all ModDetails, all linked code---   - all unlinked code that is out of date with respect to---     the source file------ This is VERY IMPORTANT otherwise we'll end up requiring 2x the--- space at the end of the upsweep, because the topmost ModDetails of the--- old HPT holds on to the entire type environment from the previous--- compilation.--- Note [GHC Heap Invariants]-pruneCache :: [CachedIface]-                      -> [ModSummary]-                      -> [HomeModInfo]-pruneCache hpt summ-  = strictMap prune hpt-  where prune (CachedIface { cached_modiface = iface-                           , cached_linkable = linkable-                           }) = HomeModInfo iface emptyModDetails linkable'-          where-           modl = miKey iface-           linkable'-                | Just ms <- M.lookup modl ms_map-                , mi_src_hash iface /= ms_hs_hash ms-                = emptyHomeModInfoLinkable-                | otherwise-                = linkable--        -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error.-        ms_map = M.fromListWith-                  (\ms1 ms2 -> assertPpr False (text "prune_cache" $$ (ppr ms1 <+> ppr ms2))-                               ms2)-                  [(msKey ms, ms) | ms <- summ]---- --------------------------------------------------------------------------------- | Unloading-unload :: Interp -> HscEnv -> IO ()-unload interp hsc_env-  = case ghcLink (hsc_dflags hsc_env) of-        LinkInMemory -> Linker.unload interp hsc_env []-        _other -> return ()---{- Parallel Upsweep--The parallel upsweep attempts to concurrently compile the modules in the-compilation graph using multiple Haskell threads.--The Algorithm--* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is-a pair of an `IO a` action and a `MVar a`, where to place the result.-  The list is sorted topologically, so can be executed in order without fear of-  blocking.-* runPipelines takes this list and eventually passes it to runLoop which executes-  each action and places the result into the right MVar.-* The amount of parallelism is controlled by a semaphore. This is just used around the-  module compilation step, so that only the right number of modules are compiled at-  the same time which reduces overall memory usage and allocations.-* Each proper node has a LogQueue, which dictates where to send it's output.-* The LogQueue is placed into the LogQueueQueue when the action starts and a worker-  thread processes the LogQueueQueue printing logs for each module in a stable order.-* The result variable for an action producing `a` is of type `Maybe a`, therefore-  it is still filled on a failure. If a module fails to compile, the-  failure is propagated through the whole module graph and any modules which didn't-  depend on the failure can still be compiled. This behaviour also makes the code-  quite a bit cleaner.--}---{---Note [--make mode]-~~~~~~~~~~~~~~~~~-There are two main parts to `--make` mode.--1. `downsweep`: Starts from the top of the module graph and computes dependencies.-2. `upsweep`: Starts from the bottom of the module graph and compiles modules.--The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which-computers how to build this ModuleGraph.--Note [Upsweep]-~~~~~~~~~~~~~~-Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes-the plan in order to compile the project.--The first step is computing the build plan from a 'ModuleGraph'.--The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for-how to build all the modules.--```-data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle-               | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot]   -- A resolved cycle, linearised by hs-boot files-               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files-```--The plan is computed in two steps:--Step 1:  Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains-         cycles.-Step 2:  For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should-         result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.-Step 2a: For each module in the cycle, if the module has a boot file then compute the-         modules on the path between it and the hs-boot file.-         These are the intermediate modules which:-            (1) are (transitive) dependencies of the non-boot module, and-            (2) have the boot module as a (transitive) dependency.-         In particular, all such intermediate modules must appear in the same unit as-         the module under consideration, as module cycles cannot cross unit boundaries.-         This information is stored in ModuleGraphNodeWithBoot.--The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.--* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.-* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented-  with a consistent knot-tied version of modules at the end.-    - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration-      is performed both before and after the module in question is compiled.-      See Note [Hydrating Modules] for more information.-* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files-  and are reported as an error to the user.--The main trickiness of `interpretBuildPlan` is deciding which version of a dependency-is visible from each module. For modules which are not in a cycle, there is just-one version of a module, so that is always used. For modules in a cycle, there are two versions of-'HomeModInfo'.--1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.-2. External to loop: The knot-tied version created by typecheckLoop.--Whilst compiling a module inside the loop, we need to use the (1). For a module which-is outside of the loop which depends on something from in the loop, the (2) version-is used.--As the plan is interpreted, which version of a HomeModInfo is visible is updated-by updating a map held in a state monad. So after a loop has finished being compiled,-the visible module is the one created by typecheckLoop and the internal version is not-used again.--This plan also ensures the most important invariant to do with module loops:--> If you depend on anything within a module loop, before you can use the dependency,-  the whole loop has to finish compiling.--The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs-of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running-the action. This list is topologically sorted, so can be run in order to compute-the whole graph.--As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which-can be queried at the end to get the result of all modules at the end, with their proper-visibility. For example, if any module in a loop fails then all modules in that loop will-report as failed because the visible node at the end will be the result of checking-these modules together.---}---- | Simple wrapper around MVar which allows a functor instance.-data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))--deriving instance Functor ResultVar--mkResultVar :: MVar (Maybe a) -> ResultVar a-mkResultVar = ResultVar id---- | Block until the result is ready.-waitResult :: ResultVar a -> MaybeT IO a-waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)--data BuildResult = BuildResult { _resultOrigin :: ResultOrigin-                               , resultVar    :: ResultVar (Maybe HomeModInfo, ModuleNameSet)-                               }---- The origin of this result var, useful for debugging-data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Show)--data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Show)--mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult-mkBuildResult = BuildResult---data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey BuildResult-                                          -- The current way to build a specific TNodeKey, without cycles this just points to-                                          -- the appropriate result of compiling a module  but with-                                          -- cycles there can be additional indirection and can point to the result of typechecking a loop-                                     , nNODE :: Int-                                     , hug_var :: MVar HomeUnitGraph-                                     -- A global variable which is incrementally updated with the result-                                     -- of compiling modules.-                                     }--nodeId :: BuildM Int-nodeId = do-  n <- gets nNODE-  modify (\m -> m { nNODE = n + 1 })-  return n---setModulePipeline :: NodeKey -> BuildResult -> BuildM ()-setModulePipeline mgn build_result = do-  modify (\m -> m { buildDep = M.insert mgn build_result (buildDep m) })--type BuildMap = M.Map NodeKey BuildResult--getBuildMap :: BuildM BuildMap-getBuildMap = gets buildDep--getDependencies :: [NodeKey] -> BuildMap -> [BuildResult]-getDependencies direct_deps build_map =-  strictMap (expectJust "dep_map" . flip M.lookup build_map) direct_deps--type BuildM a = StateT BuildLoopState IO a------- | Environment used when compiling a module-data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module-                       , compile_sem :: !AbstractSem-                       -- Modify the environment for module k, with the supplied logger modification function.-                       -- For -j1, this wrapper doesn't do anything-                       -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output-                       --          into the log queue.-                       , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a-                       , env_messager :: !(Maybe Messager)-                       , diag_wrapper :: GhcMessage -> AnyGhcDiagnostic-                       }--type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a---- | Given the build plan, creates a graph which indicates where each NodeKey should--- get its direct dependencies from. This might not be the corresponding build action--- if the module participates in a loop. This step also labels each node with a number for the output.--- See Note [Upsweep] for a high-level description.-interpretBuildPlan :: HomeUnitGraph-                   -> Maybe ModIfaceCache-                   -> M.Map ModNodeKeyWithUid HomeModInfo-                   -> [BuildPlan]-                   -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle-                         , [MakeAction] -- Actions we need to run in order to build everything-                         , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.-interpretBuildPlan hug mhmi_cache old_hpt plan = do-  hug_var <- newMVar hug-  ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var)-  let wait = collect_results (buildDep build_map)-  return (mcycle, plans, wait)--  where-    collect_results build_map =-      sequence (map (\br -> collect_result (fst <$> resultVar br)) (M.elems build_map))-      where-        collect_result res_var = runMaybeT (waitResult res_var)--    n_mods = sum (map countMods plan)--    buildLoop :: [BuildPlan]-              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])-    -- Build the abstract pipeline which we can execute-    -- Building finished-    buildLoop []           = return (Nothing, [])-    buildLoop (plan:plans) =-      case plan of-        -- If there was no cycle, then typecheckLoop is not necessary-        SingleModule m -> do-          one_plan <- buildSingleModule Nothing NoLoop m-          (cycle, all_plans) <- buildLoop plans-          return (cycle, one_plan : all_plans)--        -- For a resolved cycle, depend on everything in the loop, then update-        -- the cache to point to this node rather than directly to the module build-        -- nodes-        ResolvedCycle ms -> do-          pipes <- buildModuleLoop ms-          (cycle, graph) <- buildLoop plans-          return (cycle, pipes ++ graph)--        -- Can't continue past this point as the cycle is unresolved.-        UnresolvedCycle ns -> return (Just ns, [])--    buildSingleModule :: Maybe [NodeKey]  -- Modules we need to rehydrate before compiling this module-                      -> ResultOrigin-                      -> ModuleGraphNode          -- The node we are compiling-                      -> BuildM MakeAction-    buildSingleModule rehydrate_nodes origin mod = do-      mod_idx <- nodeId-      !build_map <- getBuildMap-      hug_var <- gets hug_var-      -- 1. Get the direct dependencies of this module-      let direct_deps = nodeDependencies False mod-          -- It's really important to force build_deps, or the whole buildMap is retained,-          -- which would retain all the result variables, preventing us from collecting them-          -- after they are no longer used.-          !build_deps = getDependencies direct_deps build_map-      let !build_action =-            case mod of-              InstantiationNode uid iu -> do-                withCurrentUnit (moduleGraphNodeUnitId mod) $ do-                  (hug, deps) <- wait_deps_hug hug_var build_deps-                  executeInstantiationNode mod_idx n_mods hug uid iu-                  return (Nothing, deps)-              ModuleNode _build_deps ms ->-                let !old_hmi = M.lookup (msKey ms) old_hpt-                    rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes-                in withCurrentUnit (moduleGraphNodeUnitId mod) $ do-                     (hug, deps) <- wait_deps_hug hug_var build_deps-                     hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms-                     -- Write the HMI to an external cache (if one exists)-                     -- See Note [Caching HomeModInfo]-                     liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi-                     -- This global MVar is incrementally modified in order to avoid having to-                     -- recreate the HPT before compiling each module which leads to a quadratic amount of work.-                     liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi)-                     return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps )-              LinkNode _nks uid -> do-                  withCurrentUnit (moduleGraphNodeUnitId mod) $ do-                    (hug, deps) <- wait_deps_hug hug_var build_deps-                    executeLinkNode hug (mod_idx, n_mods) uid direct_deps-                    return (Nothing, deps)---      res_var <- liftIO newEmptyMVar-      let result_var = mkResultVar res_var-      setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var)-      return $! (MakeAction build_action res_var)---    buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]-    buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) = do-      ma <- buildSingleModule (Just deps) (Loop Initialise) mn-      -- Rehydration (1) from Note [Hydrating Modules], "Loops with multiple boot files"-      rehydrate_action <- rehydrateAction Rehydrated ((GWIB (mkNodeKey mn) IsBoot) : (map (\d -> GWIB d NotBoot) deps))-      return $ [ma, rehydrate_action]---    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction]-    buildModuleLoop ms = do-      build_modules <- concatMapM (either (fmap (:[]) <$> buildSingleModule Nothing (Loop Initialise)) buildOneLoopyModule) ms-      let extract (Left mn) = GWIB (mkNodeKey mn) NotBoot-          extract (Right (ModuleGraphNodeWithBootFile mn _)) = GWIB (mkNodeKey mn) IsBoot-      let loop_mods = map extract ms-      -- Rehydration (2) from Note [Hydrating Modules], "Loops with multiple boot files"-      -- Fixes the space leak described in that note.-      rehydrate_action <- rehydrateAction Finalised loop_mods--      return $ build_modules ++ [rehydrate_action]--    -- An action which rehydrates the given keys-    rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction-    rehydrateAction origin deps = do-      hug_var <- gets hug_var-      !build_map <- getBuildMap-      res_var <- liftIO newEmptyMVar-      let loop_unit :: UnitId-          !loop_unit = nodeKeyUnitId (gwib_mod (head deps))-          !build_deps = getDependencies (map gwib_mod deps) build_map-      let loop_action = withCurrentUnit loop_unit $ do-            (hug, tdeps) <- wait_deps_hug hug_var build_deps-            hsc_env <- asks hsc_env-            let new_hsc = setHUG hug hsc_env-                mns :: [ModuleName]-                mns = mapMaybe (nodeKeyModName . gwib_mod) deps--            hmis' <- liftIO $ rehydrateAfter new_hsc mns--            checkRehydrationInvariant hmis' deps--            -- Add hydrated interfaces to global variable-            liftIO $ modifyMVar_ hug_var (\hug -> return $ foldr addHomeModInfoToHug hug hmis')-            return (hmis', tdeps)--      let fanout i = first (Just . (!! i)) <$> mkResultVar res_var-      -- From outside the module loop, anyone must wait for the loop to finish and then-      -- use the result of the rehydrated iface. This makes sure that things not in the-      -- module loop will see the updated interfaces for all the identifiers in the loop.-          boot_key :: NodeKey -> NodeKey-          boot_key (NodeKey_Module m) = NodeKey_Module (m { mnkModuleName = (mnkModuleName m) { gwib_isBoot = IsBoot } } )-          boot_key k = pprPanic "boot_key" (ppr k)--          update_module_pipeline (m, i) =-            case gwib_isBoot m of-              NotBoot -> setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i))-              IsBoot -> do-                setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i))-                -- SPECIAL: Anything outside the loop needs to see A rather than A.hs-boot-                setModulePipeline (boot_key (gwib_mod m)) (mkBuildResult (Loop origin) (fanout i))--      let deps_i = zip deps [0..]-      mapM update_module_pipeline deps_i--      return $ MakeAction loop_action res_var--      -- Checks that the interfaces returned from hydration match-up with the names of the-      -- modules which were fed into the function.-    checkRehydrationInvariant hmis deps =-        let hmi_names = map (moduleName . mi_module . hm_iface) hmis-            start = mapMaybe (nodeKeyModName . gwib_mod) deps-        in massertPpr (hmi_names == start) $ (ppr hmi_names $$ ppr start)---withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a-withCurrentUnit uid = do-  local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})--upsweep-    :: WorkerLimit -- ^ The number of workers we wish to run in parallel-    -> HscEnv -- ^ The base HscEnv, which is augmented for each module-    -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to-    -> (GhcMessage -> AnyGhcDiagnostic)-    -> Maybe Messager-    -> M.Map ModNodeKeyWithUid HomeModInfo-    -> [BuildPlan]-    -> IO (SuccessFlag, [HomeModInfo])-upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = do-    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan-    runPipelines n_jobs hsc_env diag_wrapper mHscMessage pipelines-    res <- collect_result--    let completed = [m | Just (Just m) <- res]--    -- Handle any cycle in the original compilation graph and return the result-    -- of the upsweep.-    case cycle of-        Just mss -> do-          throwOneError $ cyclicModuleErr mss-        Nothing  -> do-          let success_flag = successIf (all isJust res)-          return (success_flag, completed)--toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo-toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])--miKey :: ModIface -> ModNodeKeyWithUid-miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))--upsweep_inst :: HscEnv-             -> Maybe Messager-             -> Int  -- index of module-             -> Int  -- total number of modules-             -> UnitId-             -> InstantiatedUnit-             -> IO ()-upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do-        case mHscMessage of-            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid)-            Nothing -> return ()-        runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid-        pure ()---- | Compile a single module.  Always produce a Linkable for it if--- successful.  If no compilation happened, return the old Linkable.-upsweep_mod :: HscEnv-            -> Maybe Messager-            -> Maybe HomeModInfo-            -> ModSummary-            -> Int  -- index of module-            -> Int  -- total number of modules-            -> IO HomeModInfo-upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods =  do-  hmi <- compileOne' mHscMessage hsc_env summary-          mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi)--  -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module-  -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I-  -- am unsure if this is sound (wrt running TH splices for example).-  -- This function only does anything if the linkable produced is a BCO, which-  -- used to only happen with the bytecode backend, but with-  -- @-fprefer-byte-code@, @HomeModInfo@ has bytecode even when generating-  -- object code, see #25230.-  addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)-                (homeModInfoByteCode hmi)--  return hmi---- | Add the entries from a BCO linkable to the SPT table, see--- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.-addSptEntries :: HscEnv -> Maybe Linkable -> IO ()-addSptEntries hsc_env mlinkable =-  hscAddSptEntries hsc_env-     [ spt-     | linkable <- maybeToList mlinkable-     , bco <- linkableBCOs linkable-     , spt <- bc_spt_entries bco-     ]--{- Note [-fno-code mode]-~~~~~~~~~~~~~~~~~~~~~~~~-GHC offers the flag -fno-code for the purpose of parsing and typechecking a-program without generating object files. This is intended to be used by tooling-and IDEs to provide quick feedback on any parser or type errors as cheaply as-possible.--When GHC is invoked with -fno-code no object files or linked output will be-generated. As many errors and warnings as possible will be generated, as if--fno-code had not been passed. The session DynFlags will have-backend == NoBackend.---fwrite-interface-~~~~~~~~~~~~~~~~-Whether interface files are generated in -fno-code mode is controlled by the--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is-not also passed. Recompilation avoidance requires interface files, so passing--fno-code without -fwrite-interface should be avoided. If -fno-code were-re-implemented today, -fwrite-interface would be discarded and it would be-considered always on; this behaviour is as it is for backwards compatibility.--================================================================-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER-================================================================--Template Haskell-~~~~~~~~~~~~~~~~-A module using template haskell may invoke an imported function from inside a-splice. This will cause the type-checker to attempt to execute that code, which-would fail if no object files had been generated. See #8025. To rectify this,-during the downsweep we patch the DynFlags in the ModSummary of any home module-that is imported by a module that uses template haskell, to generate object-code.--The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled-or not in the module which needs the code generation. If the module requires byte-code then-dependencies will generate byte-code, otherwise they will generate object files.-In the case where some modules require byte-code and some object files, both are-generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these-configurations.--The object files (and interface files if -fwrite-interface is disabled) produced-for template haskell are written to temporary files.--Note that since template haskell can run arbitrary IO actions, -fno-code mode-is no more secure than running without it.--Potential TODOS:-~~~~~-* Remove -fwrite-interface and have interface files always written in -fno-code-  mode-* Both .o and .dyn_o files are generated for template haskell, but we only need-  .dyn_o. Fix it.-* In make mode, a message like-  Compiling A (A.hs, /tmp/ghc_123.o)-  is shown if downsweep enabled object code generation for A. Perhaps we should-  show "nothing" or "temporary object file" instead. Note that one-  can currently use -keep-tmp-files and inspect the generated file with the-  current behaviour.-* Offer a -no-codedir command line option, and write what were temporary-  object files there. This would speed up recompilation.-* Use existing object files (if they are up to date) instead of always-  generating temporary ones.--}---- Note [When source is considered modified]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- A number of functions in GHC.Driver accept a SourceModified argument, which--- is part of how GHC determines whether recompilation may be avoided (see the--- definition of the SourceModified data type for details).------ Determining whether or not a source file is considered modified depends not--- only on the source file itself, but also on the output files which compiling--- that module would produce. This is done because GHC supports a number of--- flags which control which output files should be produced, e.g. -fno-code--- -fwrite-interface and -fwrite-ide-file; we must check not only whether the--- source file has been modified since the last compile, but also whether the--- source file has been modified since the last compile which produced all of--- the output files which have been requested.------ Specifically, a source file is considered unmodified if it is up-to-date--- relative to all of the output files which have been requested. Whether or--- not an output file is up-to-date depends on what kind of file it is:------ * iface (.hi) files are considered up-to-date if (and only if) their---   mi_src_hash field matches the hash of the source file,------ * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date---   if (and only if) their modification times on the filesystem are greater---   than or equal to the modification time of the corresponding .hi file.------ Why do we use '>=' rather than '>' for output files other than the .hi file?--- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a--- resolution of 2 seconds), we may often find that the .hi and .o files have--- the same modification time. Using >= is slightly unsafe, but it matches--- make's behaviour.------ This strategy allows us to do the minimum work necessary in order to ensure--- that all the files the user cares about are up-to-date; e.g. we should not--- worry about .o files if the user has indicated that they are not interested--- in them via -fno-code. See also #9243.------ Note that recompilation avoidance is dependent on .hi files being produced,--- which does not happen if -fno-write-interface -fno-code is passed. That is,--- passing -fno-write-interface -fno-code means that you cannot benefit from--- recompilation avoidance. See also Note [-fno-code mode].------ The correctness of this strategy depends on an assumption that whenever we--- are producing multiple output files, the .hi file is always written first.--- If this assumption is violated, we risk recompiling unnecessarily by--- incorrectly regarding non-.hi files as outdated.------- --------------------------------------------------------------------------------- | Topological sort of the module graph-topSortModuleGraph-          :: Bool-          -- ^ Drop hi-boot nodes? (see below)-          -> ModuleGraph-          -> Maybe HomeUnitModule-             -- ^ Root module name.  If @Nothing@, use the full graph.-          -> [SCC ModuleGraphNode]--- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes--- The resulting list of strongly-connected-components is in topologically--- sorted order, starting with the module(s) at the bottom of the--- dependency graph (ie compile them first) and ending with the ones at--- the top.------ Drop hi-boot nodes (first boolean arg)?------ - @False@:   treat the hi-boot summaries as nodes of the graph,---              so the graph must be acyclic------ - @True@:    eliminate the hi-boot nodes, and instead pretend---              the a source-import of Foo is an import of Foo---              The resulting graph has no hi-boot nodes, but can be cyclic-topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =-    -- stronglyConnCompG flips the original order, so if we reverse-    -- the summaries we get a stable topological sort.-  topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod--topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]-topSortModules drop_hs_boot_nodes summaries mb_root_mod-  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph-  where-    (graph, lookup_node) =-      moduleGraphNodes drop_hs_boot_nodes summaries--    initial_graph = case mb_root_mod of-        Nothing -> graph-        Just (Module uid root_mod) ->-            -- restrict the graph to just those modules reachable from-            -- the specified module.  We do this by building a graph with-            -- the full set of nodes, and determining the reachable set from-            -- the specified node.-            let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid-                     , graph `hasVertexG` node-                     = node-                     | otherwise-                     = throwGhcException (ProgramError "module does not exist")-            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))--newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }-  deriving (Functor, Traversable, Foldable)--emptyModNodeMap :: ModNodeMap a-emptyModNodeMap = ModNodeMap Map.empty--modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a-modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)--modNodeMapElems :: ModNodeMap a -> [a]-modNodeMapElems (ModNodeMap m) = Map.elems m--modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a-modNodeMapLookup k (ModNodeMap m) = Map.lookup k m--modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a-modNodeMapSingleton k v = ModNodeMap (M.singleton k v)--modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a-modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n)---- | If there are {-# SOURCE #-} imports between strongly connected--- components in the topological sort, then those imports can--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE--- were necessary, then the edge would be part of a cycle.-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()-warnUnnecessarySourceImports sccs = do-  diag_opts <- initDiagOpts <$> getDynFlags-  when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do-    let check ms =-           let mods_in_this_cycle = map ms_mod_name ms in-           [ warn i | m <- ms, i <- ms_home_srcimps m,-                      unLoc i `notElem`  mods_in_this_cycle ]--        warn :: Located ModuleName -> MsgEnvelope GhcMessage-        warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts-                                                  loc (DriverUnnecessarySourceImports mod)-    logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))----- This caches the answer to the question, if we are in this unit, what does--- an import of this module mean.-type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]------------------------------------------------------------------------------------- | Downsweep (dependency analysis)------ Chase downwards from the specified root set, returning summaries--- for all home modules encountered.  Only follow source-import--- links.------ We pass in the previous collection of summaries, which is used as a--- cache to avoid recalculating a module summary if the source is--- unchanged.------ The returned list of [ModSummary] nodes has one node for each home-package--- module, plus one for any hs-boot files.  The imports of these nodes--- are all there, including the imports of non-home-package modules.-downsweep :: HscEnv-          -> [ModSummary]-          -- ^ Old summaries-          -> [ModuleName]       -- Ignore dependencies on these; treat-                                -- them as if they were package modules-          -> Bool               -- True <=> allow multiple targets to have-                                --          the same module name; this is-                                --          very useful for ghc -M-          -> IO ([DriverMessages], [ModuleGraphNode])-                -- The non-error elements of the returned list all have distinct-                -- (Modules, IsBoot) identifiers, unless the Bool is true in-                -- which case there can be repeats-downsweep hsc_env old_summaries excl_mods allow_dup_roots-   = do-       (root_errs, rootSummariesOk) <- partitionWithM getRootSummary roots -- #17549-       let root_map = mkRootMap rootSummariesOk-       checkDuplicates root_map-       (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)-       let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)-       let unit_env = hsc_unit_env hsc_env-       let tmpfs    = hsc_tmpfs    hsc_env--       let downsweep_errs = lefts $ concat $ M.elems map0-           downsweep_nodes = M.elems deps--           (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)-           all_nodes = downsweep_nodes ++ unit_nodes-           all_errs  = all_root_errs ++  downsweep_errs ++ other_errs-           all_root_errs =  closure_errs ++ map snd root_errs--       -- if we have been passed -fno-code, we enable code generation-       -- for dependencies of modules that have -XTemplateHaskell,-       -- otherwise those modules will fail to compile.-       -- See Note [-fno-code mode] #8025-       th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes-       if null all_root_errs-         then return (all_errs, th_enabled_nodes)-         else pure $ (all_root_errs, [])-     where-        -- Dependencies arising on a unit (backpack and module linking deps)-        unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]-        unitModuleNodes summaries uid hue =-          let instantiation_nodes = instantiationNodes uid (homeUnitEnv_units hue)-          in map Right instantiation_nodes-              ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue)--        calcDeps ms =-          -- Add a dependency on the HsBoot file if it exists-          -- This gets passed to the loopImports function which just ignores it if it-          -- can't be found.-          [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++-          [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]--        logger = hsc_logger hsc_env-        roots  = hsc_targets hsc_env--        -- A cache from file paths to the already summarised modules. The same file-        -- can be used in multiple units so the map is also keyed by which unit the-        -- file was used in.-        -- Reuse these if we can because the most expensive part of downsweep is-        -- reading the headers.-        old_summary_map :: M.Map (UnitId, FilePath) ModSummary-        old_summary_map = M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]--        getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)-        getRootSummary Target { targetId = TargetFile file mb_phase-                              , targetContents = maybe_buf-                              , targetUnitId = uid-                              }-           = do let offset_file = augmentByWorkingDirectory dflags file-                exists <- liftIO $ doesFileExist offset_file-                if exists || isJust maybe_buf-                    then first (uid,) <$>-                        summariseFile hsc_env home_unit old_summary_map offset_file mb_phase-                                       maybe_buf-                    else return $ Left $ (uid,) $ singleMessage-                                $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)-            where-              dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))-              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)-        getRootSummary Target { targetId = TargetModule modl-                              , targetContents = maybe_buf-                              , targetUnitId = uid-                              }-           = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot-                                           (L rootLoc modl) (ThisPkg (homeUnitId home_unit))-                                           maybe_buf excl_mods-                case maybe_summary of-                   FoundHome s  -> return (Right s)-                   FoundHomeWithError err -> return (Left err)-                   _ -> return $ Left $ (uid, moduleNotFoundErr modl)-            where-              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)-        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")--        -- In a root module, the filename is allowed to diverge from the module-        -- name, so we have to check that there aren't multiple root files-        -- defining the same module (otherwise the duplicates will be silently-        -- ignored, leading to confusing behaviour).-        checkDuplicates-          :: DownsweepCache-          -> IO ()-        checkDuplicates root_map-           | allow_dup_roots = return ()-           | null dup_roots  = return ()-           | otherwise       = liftIO $ multiRootsErr (head dup_roots)-           where-             dup_roots :: [[ModSummary]]        -- Each at least of length 2-             dup_roots = filterOut isSingleton $ map rights (M.elems root_map)--        -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit-        loopSummaries :: [ModSummary]-              -> (M.Map NodeKey ModuleGraphNode,-                    DownsweepCache)-              -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)-        loopSummaries [] done = return done-        loopSummaries (ms:next) (done, summarised)-          | Just {} <- M.lookup k done-          = loopSummaries next (done, summarised)-          -- Didn't work out what the imports mean yet, now do that.-          | otherwise = do-             (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised-             -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.-             (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'-             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'')-          where-            k = NodeKey_Module (msKey ms)--            hs_file_for_boot-              | HsBootFile <- ms_hsc_src ms-              = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))-              | otherwise-              = Nothing---        -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover-        -- a new module by doing this.-        loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]-                        -- Work list: process these modules-             -> M.Map NodeKey ModuleGraphNode-             -> DownsweepCache-                        -- Visited set; the range is a list because-                        -- the roots can have the same module names-                        -- if allow_dup_roots is True-             -> IO ([NodeKey],-                  M.Map NodeKey ModuleGraphNode, DownsweepCache)-                        -- The result is the completed NodeMap-        loopImports [] done summarised = return ([], done, summarised)-        loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised-          | Just summs <- M.lookup cache_key summarised-          = case summs of-              [Right ms] -> do-                let nk = NodeKey_Module (msKey ms)-                (rest, summarised', done') <- loopImports ss done summarised-                return (nk: rest, summarised', done')-              [Left _err] ->-                loopImports ss done summarised-              _errs ->  do-                loopImports ss done summarised-          | otherwise-          = do-               mb_s <- summariseModule hsc_env home_unit old_summary_map-                                       is_boot wanted_mod mb_pkg-                                       Nothing excl_mods-               case mb_s of-                   NotThere -> loopImports ss done summarised-                   External _ -> do-                    (other_deps, done', summarised') <- loopImports ss done summarised-                    return (other_deps, done', summarised')-                   FoundInstantiation iud -> do-                    (other_deps, done', summarised') <- loopImports ss done summarised-                    return (NodeKey_Unit iud : other_deps, done', summarised')-                   FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)-                   FoundHome s -> do-                     (done', summarised') <--                       loopSummaries [s] (done, Map.insert cache_key [Right s] summarised)-                     (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'--                     -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.-                     return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised)-          where-            cache_key = (home_uid, mb_pkg, unLoc <$> gwib)-            home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)-            GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib-            wanted_mod = L loc mod---- | This function checks then important property that if both p and q are home units--- then any dependency of p, which transitively depends on q is also a home unit.------ See Note [Multiple Home Units], section 'Closure Property'.-checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]-checkHomeUnitsClosed ue-    | Set.null bad_unit_ids = []-    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]-  where-    home_id_set = unitEnv_keys $ ue_home_unit_graph ue-    bad_unit_ids = upwards_closure Set.\\ home_id_set-    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")--    graph :: Graph (Node UnitId UnitId)-    graph = graphFromEdgedVerticesUniq graphNodes--    -- downwards closure of graph-    downwards_closure-      = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps)-                                   | (uid, deps) <- M.toList (allReachable graph node_key)]--    inverse_closure = transposeG downwards_closure--    upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]--    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)-    all_unit_direct_deps-      = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue-      where-        go rest this this_uis =-           plusUniqMap_C Set.union-             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))-             rest-           where-             external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)-             this_units = homeUnitEnv_units this_uis-             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]--    graphNodes :: [Node UnitId UnitId]-    graphNodes = go Set.empty home_id_set-      where-        go done todo-          = case Set.minView todo of-              Nothing -> []-              Just (uid, todo')-                | Set.member uid done -> go done todo'-                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of-                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))-                    Just depends ->-                      let todo'' = (depends Set.\\ done) `Set.union` todo'-                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''---- | Update the every ModSummary that is depended on--- by a module that needs template haskell. We enable codegen to--- the specified target, disable optimization and change the .hi--- and .o file locations to be temporary files.--- See Note [-fno-code mode]-enableCodeGenForTH-  :: Logger-  -> TmpFs-  -> UnitEnv-  -> [ModuleGraphNode]-  -> IO [ModuleGraphNode]-enableCodeGenForTH logger tmpfs unit_env =-  enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env---data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord)--instance Outputable CodeGenEnable where-  ppr = text . show---- | Helper used to implement 'enableCodeGenForTH'.--- In particular, this enables--- unoptimized code generation for all modules that meet some--- condition (first parameter), or are dependencies of those--- modules. The second parameter is a condition to check before--- marking modules for code generation.-enableCodeGenWhen-  :: Logger-  -> TmpFs-  -> TempFileLifetime-  -> TempFileLifetime-  -> UnitEnv-  -> [ModuleGraphNode]-  -> IO [ModuleGraphNode]-enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =-  mapM enable_code_gen mod_graph-  where-    defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)-    enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode-    enable_code_gen n@(ModuleNode deps ms)-      | ModSummary-        { ms_location = ms_location-        , ms_hsc_src = HsSrcFile-        , ms_hspp_opts = dflags-        } <- ms-      , Just enable_spec <- mkNodeKey n `Map.lookup` needs_codegen_map =-      if | nocode_enable ms -> do-               let new_temp_file suf dynsuf = do-                     tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf-                     let dyn_tn = tn -<.> dynsuf-                     addFilesToClean tmpfs dynLife [dyn_tn]-                     return (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn)-                 -- We don't want to create .o or .hi files unless we have been asked-                 -- to by the user. But we need them, so we patch their locations in-                 -- the ModSummary with temporary files.-                 ---               ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <--                 -- If ``-fwrite-interface` is specified, then the .o and .hi files-                 -- are written into `-odir` and `-hidir` respectively.  #16670-                 if gopt Opt_WriteInterface dflags-                   then return ((ml_hi_file_ospath ms_location, ml_dyn_hi_file_ospath ms_location)-                               , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location))-                   else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))-                            <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))-               let new_dflags = case enable_spec of-                                  EnableByteCode -> dflags { backend = interpreterBackend }-                                  EnableObject   -> dflags { backend = defaultBackendOf ms }-                                  EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}-               let ms' = ms-                     { ms_location =-                         ms_location { ml_hi_file_ospath = hi_file-                                     , ml_obj_file_ospath = o_file-                                     , ml_dyn_hi_file_ospath = dyn_hi_file-                                     , ml_dyn_obj_file_ospath = dyn_o_file }-                     , ms_hspp_opts = updOptLevel 0 $ new_dflags-                     }-               -- Recursive call to catch the other cases-               enable_code_gen (ModuleNode deps ms')--         -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough)-         -- we only get to this case if the default backend is already generating object files, but we need dynamic-         -- objects-         | bytecode_and_enable enable_spec ms -> do-               let ms' = ms-                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode-                     }-               -- Recursive call to catch the other cases-               enable_code_gen (ModuleNode deps ms')-         | dynamic_too_enable enable_spec ms -> do-               let ms' = ms-                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo-                     }-               -- Recursive call to catch the other cases-               enable_code_gen (ModuleNode deps ms')-         | ext_interp_enable ms -> do-               let ms' = ms-                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter-                     }-               -- Recursive call to catch the other cases-               enable_code_gen (ModuleNode deps ms')--         | otherwise -> return n--    enable_code_gen ms = return ms--    nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =-      not (backendGeneratesCode (backend dflags)) &&-      -- Don't enable codegen for TH on indefinite packages; we-      -- can't compile anything anyway! See #16219.-      isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)--    bytecode_and_enable enable_spec ms =-      -- In the situation where we **would** need to enable dynamic-too-      -- IF we had decided we needed objects-      dynamic_too_enable EnableObject ms-        -- but we prefer to use bytecode rather than objects-        && prefer_bytecode-        -- and we haven't already turned it on-        && not generate_both-      where-        lcl_dflags   = ms_hspp_opts ms-        prefer_bytecode = case enable_spec of-                            EnableByteCodeAndObject -> True-                            EnableByteCode -> True-                            EnableObject -> False--        generate_both   = gopt Opt_ByteCodeAndObjectCode lcl_dflags--    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so-    -- the linker can correctly load the object files.  This isn't necessary-    -- when using -fexternal-interpreter.-    dynamic_too_enable enable_spec ms-      | sTargetRTSLinkerOnlySupportsSharedLibs $ settings lcl_dflags =-          not isDynWay && not dyn_too_enabled-            && enable_object-      | otherwise =-          hostIsDynamic && not hostIsProfiled && internalInterpreter &&-            not isDynWay && not isProfWay &&  not dyn_too_enabled-              && enable_object-      where-       lcl_dflags   = ms_hspp_opts ms-       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)-       dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags-       isDynWay    = hasWay (ways lcl_dflags) WayDyn-       isProfWay   = hasWay (ways lcl_dflags) WayProf-       enable_object = case enable_spec of-                            EnableByteCode -> False-                            EnableByteCodeAndObject -> True-                            EnableObject -> True--    -- #16331 - when no "internal interpreter" is available but we-    -- need to process some TemplateHaskell or QuasiQuotes, we automatically-    -- turn on -fexternal-interpreter.-    ext_interp_enable ms = not ghciSupported && internalInterpreter-      where-       lcl_dflags   = ms_hspp_opts ms-       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)--    (mg, lookup_node) = moduleGraphNodes False mod_graph--    mk_needed_set roots = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) roots)--    needs_obj_set, needs_bc_set :: Set.Set NodeKey-    needs_obj_set = mk_needed_set need_obj_set--    needs_bc_set = mk_needed_set need_bc_set--    -- A map which tells us how to enable code generation for a NodeKey-    needs_codegen_map :: Map.Map NodeKey CodeGenEnable-    needs_codegen_map =-      -- Another option here would be to just produce object code, rather than both object and-      -- byte code-      Map.unionWith (\_ _ -> EnableByteCodeAndObject)-        (Map.fromList $ [(m, EnableObject) | m <- Set.toList needs_obj_set])-        (Map.fromList $ [(m, EnableByteCode) | m <- Set.toList needs_bc_set])--    -- The direct dependencies of modules which require object code-    need_obj_set =-      concat-        -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only-        -- it's dependencies.-        [ deps-        | (ModuleNode deps ms) <- mod_graph-        , isTemplateHaskellOrQQNonBoot ms-        , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))-        ]--    -- The direct dependencies of modules which require byte code-    need_bc_set =-      concat-        [ deps-        | (ModuleNode deps ms) <- mod_graph-        , isTemplateHaskellOrQQNonBoot ms-        , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)-        ]---- | Populate the Downsweep cache with the root modules.-mkRootMap-  :: [ModSummary]-  -> DownsweepCache-mkRootMap summaries = Map.fromListWith (flip (++))-  [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ]---------------------------------------------------------------------------------- Summarising modules---- We have two types of summarisation:------    * Summarise a file.  This is used for the root module(s) passed to---      cmLoadModules.  The file is read, and used to determine the root---      module name.  The module name may differ from the filename.------    * Summarise a module.  We are given a module name, and must provide---      a summary.  The finder is used to locate the file in which the module---      resides.--summariseFile-        :: HscEnv-        -> HomeUnit-        -> M.Map (UnitId, FilePath) ModSummary    -- old summaries-        -> FilePath                     -- source file name-        -> Maybe Phase                  -- start phase-        -> Maybe (StringBuffer,UTCTime)-        -> IO (Either DriverMessages ModSummary)--summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf-        -- we can use a cached summary if one is available and the-        -- source file hasn't changed,-   | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries-   = do-        let location = ms_location $ old_summary--        src_hash <- get_src_hash-                -- The file exists; we checked in getRootSummary above.-                -- If it gets removed subsequently, then this-                -- getFileHash may fail, but that's the right-                -- behaviour.--                -- return the cached summary if the source didn't change-        checkSummaryHash-            hsc_env (new_summary src_fn)-            old_summary location src_hash--   | otherwise-   = do src_hash <- get_src_hash-        new_summary src_fn src_hash-  where-    -- change the main active unit so all operations happen relative to the given unit-    hsc_env = hscSetActiveHomeUnit home_unit hsc_env'-    -- src_fn does not necessarily exist on the filesystem, so we need to-    -- check what kind of target we are dealing with-    get_src_hash = case maybe_buf of-                      Just (buf,_) -> return $ fingerprintStringBuffer buf-                      Nothing -> liftIO $ getFileHash src_fn--    new_summary src_fn src_hash = runExceptT $ do-        preimps@PreprocessedImports {..}-            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf--        let fopts = initFinderOpts (hsc_dflags hsc_env)-            src_path = unsafeEncodeUtf src_fn--            is_boot = case takeExtension src_fn of-              ".hs-boot" -> IsBoot-              ".lhs-boot" -> IsBoot-              _ -> NotBoot--            (path_without_boot, hsc_src)-              | isHaskellSigFilename src_fn = (src_path, HsigFile)-              | IsBoot <- is_boot = (removeBootSuffix src_path, HsBootFile)-              | otherwise = (src_path, HsSrcFile)--            -- Make a ModLocation for the Finder, who only has one entry for-            -- each @ModuleName@, and therefore needs to use the locations for-            -- the non-boot files.-            location_without_boot =-              mkHomeModLocation fopts pi_mod_name path_without_boot--            -- Make a ModLocation for this file, adding the @-boot@ suffix to-            -- all paths if the original was a boot file.-            location-              | IsBoot <- is_boot-              = addBootSuffixLocn location_without_boot-              | otherwise-              = location_without_boot--        -- Tell the Finder cache where it is, so that subsequent calls-        -- to findModule will find it, even if it's not on any search path-        mod <- liftIO $ do-          let home_unit = hsc_home_unit hsc_env-          let fc        = hsc_FC hsc_env-          addHomeModuleToFinder fc home_unit (GWIB pi_mod_name is_boot) location--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_hash = src_hash-            , nms_hsc_src = hsc_src-            , nms_location = location-            , nms_mod = mod-            , nms_preimps = preimps-            }--checkSummaryHash-    :: HscEnv-    -> (Fingerprint -> IO (Either e ModSummary))-    -> ModSummary -> ModLocation -> Fingerprint-    -> IO (Either e ModSummary)-checkSummaryHash-  hsc_env new_summary-  old_summary-  location src_hash-  | ms_hs_hash old_summary == src_hash &&-      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do-           -- update the object-file timestamp-           obj_timestamp <- modificationTimeIfExists (ml_obj_file location)--           -- We have to repopulate the Finder's cache for file targets-           -- because the file might not even be on the regular search path-           -- and it was likely flushed in depanal. This is not technically-           -- needed when we're called from sumariseModule but it shouldn't-           -- hurt.-           -- Also, only add to finder cache for non-boot modules as the finder cache-           -- makes sure to add a boot suffix for boot files.-           _ <- do-              let fc = hsc_FC hsc_env-                  gwib = GWIB (ms_mod old_summary) (isBootSummary old_summary)-              case ms_hsc_src old_summary of-                HsSrcFile -> addModuleToFinder fc gwib location-                _ -> return ()--           hi_timestamp <- modificationTimeIfExists (ml_hi_file location)-           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)--           return $ Right-             ( old_summary-                     { ms_obj_date = obj_timestamp-                     , ms_iface_date = hi_timestamp-                     , ms_hie_date = hie_timestamp-                     }-             )--   | otherwise =-           -- source changed: re-summarise.-           new_summary src_hash--data SummariseResult =-        FoundInstantiation InstantiatedUnit-      | FoundHomeWithError (UnitId, DriverMessages)-      | FoundHome ModSummary-      | External UnitId-      | NotThere---- Summarise a module, and pick up source and timestamp.-summariseModule-          :: HscEnv-          -> HomeUnit-          -> M.Map (UnitId, FilePath) ModSummary-          -- ^ Map of old summaries-          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import-          -> Located ModuleName -- Imported module to be summarised-          -> PkgQual-          -> Maybe (StringBuffer, UTCTime)-          -> [ModuleName]               -- Modules to exclude-          -> IO SummariseResult---summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_pkg-                maybe_buf excl_mods-  | wanted_mod `elem` excl_mods-  = return NotThere-  | otherwise  = find_it-  where-    -- Temporarily change the currently active home unit so all operations-    -- happen relative to it-    hsc_env   = hscSetActiveHomeUnit home_unit hsc_env'-    dflags    = hsc_dflags hsc_env--    find_it :: IO SummariseResult--    find_it = do-        found <- findImportedModule hsc_env wanted_mod mb_pkg-        case found of-             Found location mod-                | isJust (ml_hs_file location) ->-                        -- Home package-                         just_found location mod-                | VirtUnit iud <- moduleUnit mod-                , not (isHomeModule home_unit mod)-                  -> return $ FoundInstantiation iud-                | otherwise -> return $ External (moduleUnitId mod)-             _ -> return NotThere-                        -- Not found-                        -- (If it is TRULY not found at all, we'll-                        -- error when we actually try to compile)--    just_found location mod = do-                -- Adjust location to point to the hs-boot source file,-                -- hi file, object file, when is_boot says so-        let location' = case is_boot of-              IsBoot -> addBootSuffixLocn location-              NotBoot -> location-            src_fn = expectJust "summarise2" (ml_hs_file location')--                -- Check that it exists-                -- It might have been deleted since the Finder last found it-        maybe_h <- fileHashIfExists src_fn-        case maybe_h of-          -- This situation can also happen if we have found the .hs file but the-          -- .hs-boot file doesn't exist.-          Nothing -> return NotThere-          Just h  -> do-            fresult <- new_summary_cache_check location' mod src_fn h-            return $ case fresult of-              Left err -> FoundHomeWithError (moduleUnitId mod, err)-              Right ms -> FoundHome ms--    new_summary_cache_check loc mod src_fn h-      | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map =--         -- check the hash on the source file, and-         -- return the cached summary if it hasn't changed.  If the-         -- file has changed then need to resummarise.-        case maybe_buf of-           Just (buf,_) ->-               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)-           Nothing    ->-               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h-      | otherwise = new_summary loc mod src_fn h--    new_summary :: ModLocation-                  -> Module-                  -> FilePath-                  -> Fingerprint-                  -> IO (Either DriverMessages ModSummary)-    new_summary location mod src_fn src_hash-      = runExceptT $ do-        preimps@PreprocessedImports {..}-            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP-            -- See multiHomeUnits_cpp2 test-            <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf--        -- NB: Despite the fact that is_boot is a top-level parameter, we-        -- don't actually know coming into this function what the HscSource-        -- of the module in question is.  This is because we may be processing-        -- this module because another module in the graph imported it: in this-        -- case, we know if it's a boot or not because of the {-# SOURCE #-}-        -- annotation, but we don't know if it's a signature or a regular-        -- module until we actually look it up on the filesystem.-        let hsc_src-              | is_boot == IsBoot           = HsBootFile-              | isHaskellSigFilename src_fn = HsigFile-              | otherwise                   = HsSrcFile--        when (pi_mod_name /= moduleName mod) $-                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc-                       $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)--        let instantiations = homeUnitInstantiations home_unit-        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $-            throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc-                   $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_hash = src_hash-            , nms_hsc_src = hsc_src-            , nms_location = location-            , nms_mod = mod-            , nms_preimps = preimps-            }---- | Convenience named arguments for 'makeNewModSummary' only used to make--- code more readable, not exported.-data MakeNewModSummary-  = MakeNewModSummary-      { nms_src_fn :: FilePath-      , nms_src_hash :: Fingerprint-      , nms_hsc_src :: HscSource-      , nms_location :: ModLocation-      , nms_mod :: Module-      , nms_preimps :: PreprocessedImports-      }--makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary-makeNewModSummary hsc_env MakeNewModSummary{..} = do-  let PreprocessedImports{..} = nms_preimps-  obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)-  dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)-  hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)-  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)--  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name-  (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps--  return $-        ModSummary-        { ms_mod = nms_mod-        , ms_hsc_src = nms_hsc_src-        , ms_location = nms_location-        , ms_hspp_file = pi_hspp_fn-        , ms_hspp_opts = pi_local_dflags-        , ms_hspp_buf  = Just pi_hspp_buf-        , ms_parsed_mod = Nothing-        , ms_srcimps = pi_srcimps-        , ms_ghc_prim_import = pi_ghc_prim_import-        , ms_textual_imps =-            ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++-            ((,) NoPkgQual . noLoc <$> implicit_sigs) ++-            pi_theimps-        , ms_hs_hash = nms_src_hash-        , ms_iface_date = hi_timestamp-        , ms_hie_date = hie_timestamp-        , ms_obj_date = obj_timestamp-        , ms_dyn_obj_date = dyn_obj_timestamp-        }--data PreprocessedImports-  = PreprocessedImports-      { pi_local_dflags :: DynFlags-      , pi_srcimps  :: [(PkgQual, Located ModuleName)]-      , pi_theimps  :: [(PkgQual, Located ModuleName)]-      , pi_ghc_prim_import :: Bool-      , pi_hspp_fn  :: FilePath-      , pi_hspp_buf :: StringBuffer-      , pi_mod_name_loc :: SrcSpan-      , pi_mod_name :: ModuleName-      }---- Preprocess the source file and get its imports--- The pi_local_dflags contains the OPTIONS pragmas-getPreprocessedImports-    :: HscEnv-    -> FilePath-    -> Maybe Phase-    -> Maybe (StringBuffer, UTCTime)-    -- ^ optional source code buffer and modification time-    -> ExceptT DriverMessages IO PreprocessedImports-getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do-  (pi_local_dflags, pi_hspp_fn)-      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase-  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn-  (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name)-      <- ExceptT $ do-          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 . getMessages) mimps)-  let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)-  let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))-  let pi_srcimps = rn_imps pi_srcimps'-  let pi_theimps = rn_imps pi_theimps'-  return PreprocessedImports {..}-----------------------------------------------------------------------------------                      Error messages---------------------------------------------------------------------------------- Defer and group warning, error and fatal messages so they will not get lost--- in the regular output.-withDeferredDiagnostics :: GhcMonad m => m a -> m a-withDeferredDiagnostics f = do-  dflags <- getDynFlags-  if not $ gopt Opt_DeferDiagnostics dflags-  then f-  else do-    warnings <- liftIO $ newIORef []-    errors <- liftIO $ newIORef []-    fatals <- liftIO $ newIORef []-    logger <- getLogger--    let deferDiagnostics _dflags !msgClass !srcSpan !msg = do-          let action = logMsg logger msgClass srcSpan msg-          case msgClass of-            MCDiagnostic SevWarning _reason _code-              -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ())-            MCDiagnostic SevError _reason _code-              -> atomicModifyIORef' errors   $ \(!i) -> (action: i, ())-            MCFatal-              -> atomicModifyIORef' fatals   $ \(!i) -> (action: i, ())-            _ -> action--        printDeferredDiagnostics = liftIO $-          forM_ [warnings, errors, fatals] $ \ref -> do-            -- This IORef can leak when the dflags leaks, so let us always-            -- reset the content. The lazy variant is used here as we want to force-            -- this error if the IORef is ever accessed again, rather than now.-            -- See #20981 for an issue which discusses this general issue.-            let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else []-            actions <- atomicModifyIORef ref $ \i -> (landmine, i)-            sequence_ $ reverse actions--    MC.bracket-      (pushLogHookM (const deferDiagnostics))-      (\_ -> popLogHookM >> printDeferredDiagnostics)-      (\_ -> f)--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 $-    DriverInterfaceError $-    (Can'tFindInterface (cannotFindModule hsc_env wanted_mod err) (LookingForModule wanted_mod NotBoot))--{--noHsFileErr :: SrcSpan -> String -> DriverMessages-noHsFileErr loc path-  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)-  -}--moduleNotFoundErr :: ModuleName -> DriverMessages-moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)--multiRootsErr :: [ModSummary] -> IO ()-multiRootsErr [] = panic "multiRootsErr"-multiRootsErr summs@(summ1:_)-  = throwOneError $ fmap GhcDriverMessage $-    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files-  where-    mod = ms_mod summ1-    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs--cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage--- From a strongly connected component we find--- a single cycle to report-cyclicModuleErr mss-  = assert (not (null mss)) $-    case findCycle graph of-       Nothing   -> pprPanic "Unexpected non-cycle" (ppr mss)-       Just path -> mkPlainErrorMsgEnvelope src_span $-                    GhcDriverMessage $ DriverModuleGraphCycle path-        where-          src_span = maybe noSrcSpan (mkFileSrcSpan . ms_location) (moduleGraphNodeModSum (head path))-  where-    graph :: [Node NodeKey ModuleGraphNode]-    graph =-      [ DigraphNode-        { node_payload = ms-        , node_key = mkNodeKey ms-        , node_dependencies = nodeDependencies False ms-        }-      | ms <- mss-      ]--cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()-cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =-  if gopt Opt_KeepTmpFiles dflags-    then liftIO $ keepCurrentModuleTempFiles logger tmpfs-    else liftIO $ cleanCurrentModuleTempFiles logger tmpfs---addDepsToHscEnv ::  [HomeModInfo] -> HscEnv -> HscEnv-addDepsToHscEnv deps hsc_env =-  hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug deps) hsc_env--setHPT ::  HomePackageTable -> HscEnv -> HscEnv-setHPT deps hsc_env =-  hscUpdateHPT (const $ deps) hsc_env--setHUG ::  HomeUnitGraph -> HscEnv -> HscEnv-setHUG deps hsc_env =-  hscUpdateHUG (const $ deps) hsc_env---- | Wrap an action to catch and handle exceptions.-wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)-wrapAction msg_wrapper hsc_env k = do-  let lcl_logger = hsc_logger hsc_env-      lcl_dynflags = hsc_dflags hsc_env-      print_config = initPrintConfig lcl_dynflags-  let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> srcErrorMessages err)-  -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle-  -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`-  -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to-  -- internally using forkIO.-  mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k-  case mres of-    Right res -> return $ Just res-    Left exc -> do-        case fromException exc of-          Just (err :: SourceError)-            -> logg err-          Nothing -> case fromException exc of-                        -- ThreadKilled in particular needs to actually kill the thread.-                        -- So rethrow that and the other async exceptions-                        Just (err :: SomeAsyncException) -> throwIO err-                        _ -> errorMsg lcl_logger (text (show exc))-        return Nothing--withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b-withParLog lqq_var k cont = do-  let init_log = do-        -- Make a new log queue-        lq <- newLogQueue k-        -- Add it into the LogQueueQueue-        atomically $ initLogQueue lqq_var lq-        return lq-      finish_log lq = liftIO (finishLogQueue lq)-  MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))--withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a-withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do-  withLogger k $ \modifyLogger -> do-    let lcl_logger = modifyLogger (hsc_logger hsc_env)-        hsc_env' = hsc_env { hsc_logger = lcl_logger }-    -- Run continuation with modified logger-    cont hsc_env'---executeInstantiationNode :: Int-  -> Int-  -> HomeUnitGraph-  -> UnitId-  -> InstantiatedUnit-  -> RunMakeM ()-executeInstantiationNode k n deps uid iu = do-        env <- ask-        -- Output of the logger is mediated by a central worker to-        -- avoid output interleaving-        msg <- asks env_messager-        wrapper <- asks diag_wrapper-        lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->-          let lcl_hsc_env = setHUG deps hsc_env-          in wrapAction wrapper lcl_hsc_env $ do-            res <- upsweep_inst lcl_hsc_env msg k n uid iu-            cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)-            return res---executeCompileNode :: Int-  -> Int-  -> Maybe HomeModInfo-  -> HomeUnitGraph-  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling-  -> ModSummary-  -> RunMakeM HomeModInfo-executeCompileNode k n !old_hmi hug mrehydrate_mods mod = do-  me@MakeEnv{..} <- ask-  -- Rehydrate any dependencies if this module had a boot file or is a signature file.-  lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do-     hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mod fixed_mrehydrate_mods-     let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas-         lcl_dynflags = ms_hspp_opts mod-     let lcl_hsc_env =-             -- Localise the hsc_env to use the cached flags-             hscSetFlags lcl_dynflags $-             hydrated_hsc_env-     -- Compile the module, locking with a semaphore to avoid too many modules-     -- being compiled at the same time leading to high memory usage.-     wrapAction diag_wrapper lcl_hsc_env $ do-      res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n-      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags-      return res)--  where-    fixed_mrehydrate_mods =-      case ms_hsc_src mod of-        -- MP: It is probably a bit of a misimplementation in backpack that-        -- compiling a signature requires an knot_var for that unit.-        -- If you remove this then a lot of backpack tests fail.-        HsigFile -> Just []-        _        -> mrehydrate_mods--{- Rehydration, see Note [Rehydrating Modules] -}--rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.-          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.-          -> IO HscEnv-rehydrate hsc_env hmis = do-  debugTraceMsg logger 2 $ (-     text "Re-hydrating loop: " <+> (ppr (map (mi_module . hm_iface) hmis)))-  new_mods <- fixIO $ \new_mods -> do-      let new_hpt = addListToHpt old_hpt new_mods-      let new_hsc_env = hscUpdateHPT_lazy (const new_hpt) hsc_env-      mds <- initIfaceCheck (text "rehydrate") new_hsc_env $-                mapM (typecheckIface . hm_iface) hmis-      let new_mods = [ (mn,hmi{ hm_details = details })-                     | (hmi,details) <- zip hmis mds-                     , let mn = moduleName (mi_module (hm_iface hmi)) ]-      return new_mods-  return $ setHPT (foldl' (\old (mn, hmi) -> addToHpt old mn hmi) old_hpt new_mods) hsc_env--  where-    logger  = hsc_logger hsc_env-    to_delete =  (map (moduleName . mi_module . hm_iface) hmis)-    -- Filter out old modules before tying the knot, otherwise we can end-    -- up with a thunk which keeps reference to the old HomeModInfo.-    !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete---- If needed, then rehydrate the necessary modules with a suitable KnotVars for the--- module currently being compiled.-maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv-maybeRehydrateBefore hsc_env _ Nothing = return hsc_env-maybeRehydrateBefore hsc_env mod (Just mns) = do-  knot_var <- initialise_knot_var hsc_env-  let hmis = map (expectJust "mr" . lookupHpt (hsc_HPT hsc_env)) mns-  rehydrate (hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) hmis--  where-   initialise_knot_var hsc_env = liftIO $-    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod)-    in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv--rehydrateAfter :: HscEnv-  -> [ModuleName]-  -> IO [HomeModInfo]-rehydrateAfter new_hsc mns = do-  let new_hpt = hsc_HPT new_hsc-      hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns-  hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) hmis-  return $ map (\mn -> expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) mn) mns--{--Note [Hydrating Modules]-~~~~~~~~~~~~~~~~~~~~~~~~-There are at least 4 different representations of an interface file as described-by this diagram.---------------------------------|       On-disk M.hi         |--------------------------------    |             ^-    | Read file   | Write file-    V             |---------------------------------|      ByteString             |---------------------------------    |             ^-    | Binary.get  | Binary.put-    V             |----------------------------------|    ModIface (an acyclic AST) |----------------------------------    |           ^-    | hydrate   | mkIfaceTc-    V           |-----------------------------------|  ModDetails (lots of cycles)  |------------------------------------The last step, converting a ModIface into a ModDetails is known as "hydration".--Hydration happens in three different places--* When an interface file is initially loaded from disk, it has to be hydrated.-* When a module is finished compiling, we hydrate the ModIface in order to generate-  the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])-* When dealing with boot files and module loops (see Note [Rehydrating Modules])--Note [Rehydrating Modules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a module has a boot file then it is critical to rehydrate the modules on-the path between the two (see #20561).--Suppose we have ("R" for "recursive"):-```-R.hs-boot:   module R where-               data T-               g :: T -> T--A.hs:        module A( f, T, g ) where-                import {-# SOURCE #-} R-                data S = MkS T-                f :: T -> S = ...g...--R.hs:        module R where-                import A-                data T = T1 | T2 S-                g = ...f...-```--== Why we need to rehydrate A's ModIface before compiling R.hs--After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type-type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same-AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about-it.)--When compiling R.hs, we build a TyCon for `T`.  But that TyCon mentions `S`, and-it currently has an AbstractTyCon for `T` inside it.  But we want to build a-fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.--Solution: **rehydration**.  *Before compiling `R.hs`*, rehydrate all the-ModIfaces below it that depend on R.hs-boot.  To rehydrate a ModIface, call-`typecheckIface` to convert it to a ModDetails.  It's just a de-serialisation-step, no type inference, just lookups.--Now `S` will be bound to a thunk that, when forced, will "see" the final binding-for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).-But note that this must be done *before* compiling R.hs.--== Why we need to rehydrate A's ModIface after compiling R.hs--When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding-mentions the `LocalId` for `g`.  But when we finish R, we carefully ensure that-all those `LocalIds` are turned into completed `GlobalIds`, replete with-unfoldings etc.   Alas, that will not apply to the occurrences of `g` in `f`'s-unfolding. And if we leave matters like that, they will stay that way, and *all*-subsequent modules that import A will see a crippled unfolding for `f`.--Solution: rehydrate both R and A's ModIface together, right after completing R.hs.--~~ Which modules to rehydrate--We only need rehydrate modules that are-* Below R.hs-* Above R.hs-boot--There might be many unrelated modules (in the home package) that don't need to be-rehydrated.--== Loops with multiple boot files--It is possible for a module graph to have a loop (SCC, when ignoring boot files)-which requires multiple boot files to break. In this case, we must perform-several hydration steps:-  1. The hydration steps described above, which are necessary for correctness.-  2. An extra hydration step at the end of compiling the entire SCC, in order to-     remove space leaks, as we explain below.--Consider the following example:--   ┌─────┐     ┌─────┐-   │  A  │     │  B  │-   └──┬──┘     └──┬──┘-      │           │-  ┌───▼───────────▼───┐-  │         C         │-  └───┬───────────┬───┘-      │           │- ┌────▼───┐   ┌───▼────┐- │ A-boot │   │ B-boot │- └────────┘   └────────┘--A, B and C live together in a SCC. Suppose that we compile the modules in the-order:--  A-boot, B-boot, C, A, B.--When we come to compile A, we will perform the necessary hydration steps,-because A has a boot file. This means that C will be hydrated relative to A,-and the ModDetails for A will reference C/A. Then, when B is compiled,-C will be rehydrated again, and so B will reference C/A,B. At this point,-its interface will be hydrated relative to both A and B.-This causes a space leak: there are now two different copies of C's ModDetails,-kept alive by modules A and B. This is especially problematic if C is large.--The way to avoid this space leak is to rehydrate an entire SCC together at the-end of compilation, so that all the ModDetails point to interfaces for .hs files.-In this example, when we hydrate A, B and C together, then both A and B will refer to-C/A,B.--See #21900 for some more discussion.--== Modules "above" the loop--This dark corner is the subject of #14092.--Suppose we add to our example-```-X.hs     module X where-           import A-           data XT = MkX T-           fx = ...g...-```-If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the argument type of `MkX`.  So:--* Either we should delay compiling X until after R has been compiled. (This is what we do)-* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.--Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.-#20200 has lots of issues, many of them now fixed;-this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).--The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.-Also closely related are-    * #14092-    * #14103---}--executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()-executeLinkNode hug kn uid deps = do-  withCurrentUnit uid $ do-    MakeEnv{..} <- ask-    let dflags = hsc_dflags hsc_env-    let hsc_env' = setHUG hug hsc_env-        msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager--    linkresult <- liftIO $ withAbstractSem compile_sem $ do-                            link (ghcLink dflags)-                                (hsc_logger hsc_env')-                                (hsc_tmpfs hsc_env')-                                (hsc_FC hsc_env')-                                (hsc_hooks hsc_env')-                                dflags-                                (hsc_unit_env hsc_env')-                                True -- We already decided to link-                                msg'-                                (hsc_HPT hsc_env')-    case linkresult of-      Failed -> fail "Link Failed"-      Succeeded -> return ()--{--Note [ModuleNameSet, efficiency and space leaks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--During upsweep, the results of compiling modules are placed into a MVar. When we need-to compute the right compilation environment for a module, we consult this MVar and-set the HomeUnitGraph accordingly. This is done to avoid having to precisely track-module dependencies and recreating the HUG from scratch each time, which is very expensive.--In serial mode (-j1), this all works out fine: a module can only be compiled-after its dependencies have finished compiling, and compilation can't be-interleaved with the compilation of other module loops. This ensures that-the HUG only ever contains finalised interfaces.--In parallel mode, we have to be more careful: the HUG variable can contain non-finalised-interfaces, which have been started by another thread. In order to avoid a space leak-in which a finalised interface is compiled against a HPT which contains a non-finalised-interface, we have to restrict the HUG to only contain the visible modules.--The collection of visible modules explains which transitive modules are visible-from a certain point. It is recorded in the ModuleNameSet.-Before a module is compiled, we use this set to restrict the HUG to the visible-modules only, avoiding this tricky space leak.--Efficiency of the ModuleNameSet is of utmost importance, because a union occurs for-each edge in the module graph. To achieve this, the set is represented directly as an IntSet,-which provides suitable performance – even using a UniqSet (which is backed by an IntMap) is-too slow. The crucial test of performance here is the time taken to a do a no-op build in --make mode.--See test "jspace" for an example which used to trigger this problem.---}---- See Note [ModuleNameSet, efficiency and space leaks]-type ModuleNameSet = M.Map UnitId W.Word64Set--addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet-addToModuleNameSet uid mn s =-  let k = (getKey $ getUnique $ mn)-  in M.insertWith (W.union) uid (W.singleton k) s---- | Wait for some dependencies to finish and then read from the given MVar.-wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)-wait_deps_hug hug_var deps = do-  (_, module_deps) <- wait_deps deps-  hug <- liftIO $ readMVar hug_var-  let pruneHomeUnitEnv uid hme =-        let -- Restrict to things which are in the transitive closure to avoid retaining-            -- reference to loop modules which have already been compiled by other threads.-            -- See Note [ModuleNameSet, efficiency and space leaks]-            !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe W.empty $ M.lookup  uid module_deps)-        in hme { homeUnitEnv_hpt = new }-  return (unitEnv_mapWithKey pruneHomeUnitEnv hug, module_deps)---- | Wait for dependencies to finish, and then return their results.-wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)-wait_deps [] = return ([], M.empty)-wait_deps (x:xs) = do-  (res, deps) <- lift $ waitResult (resultVar x)-  (hmis, all_deps) <- wait_deps xs-  let !new_deps = deps `unionModuleNameSet` all_deps-  case res of-    Nothing -> return (hmis, new_deps)-    Just hmi -> return (hmi:hmis, new_deps)-  where-    unionModuleNameSet = M.unionWith W.union----- Executing the pipelines---label_self :: String -> IO ()-label_self thread_name = do-    self_tid <- CC.myThreadId-    CC.labelThread self_tid thread_name---runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()--- Don't even initialise plugins if there are no pipelines-runPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines = do-  liftIO $ label_self "main --make thread"-  case n_job of-    NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env diag_wrapper mHscMessager all_pipelines-    _n -> runParPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines--runSeqPipelines :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()-runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines =-  let env = MakeEnv { hsc_env = plugin_hsc_env-                    , withLogger = \_ k -> k id-                    , compile_sem = AbstractSem (return ()) (return ())-                    , env_messager = mHscMessager-                    , diag_wrapper = diag_wrapper-                    }-  in runAllPipelines (NumProcessorsLimit 1) env all_pipelines--runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a-runNjobsAbstractSem n_jobs action = do-  compile_sem <- newQSem n_jobs-  n_capabilities <- getNumCapabilities-  n_cpus <- getNumProcessors-  let-    asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)-    set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n-    updNumCapabilities =  do-      -- Setting number of capabilities more than-      -- CPU count usually leads to high userspace-      -- lock contention. #9221-      set_num_caps $ min n_jobs n_cpus-    resetNumCapabilities = set_num_caps n_capabilities-  MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem--runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a-runWorkerLimit worker_limit action = case worker_limit of-    NumProcessorsLimit n_jobs ->-      runNjobsAbstractSem n_jobs action-    JSemLimit sem ->-      runJSemAbstractSem sem action---- | Build and run a pipeline-runParPipelines :: WorkerLimit -- ^ How to limit work parallelism-             -> HscEnv         -- ^ The basic HscEnv which is augmented with specific info for each module-             -> (GhcMessage -> AnyGhcDiagnostic)-             -> Maybe Messager   -- ^ Optional custom messager to use to report progress-             -> [MakeAction]  -- ^ The build plan for all the module nodes-             -> IO ()-runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipelines = do---  -- A variable which we write to when an error has happened and we have to tell the-  -- logging thread to gracefully shut down.-  stopped_var <- newTVarIO False-  -- The queue of LogQueues which actions are able to write to. When an action starts it-  -- will add it's LogQueue into this queue.-  log_queue_queue_var <- newTVarIO newLogQueueQueue-  -- Thread which coordinates the printing of logs-  wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var---  -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.-  thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)-  let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }--  runWorkerLimit worker_limit $ \abstract_sem -> do-    let env = MakeEnv { hsc_env = thread_safe_hsc_env-                      , withLogger = withParLog log_queue_queue_var-                      , compile_sem = abstract_sem-                      , env_messager = mHscMessager-                      , diag_wrapper = diag_wrapper-                      }-    -- Reset the number of capabilities once the upsweep ends.-    runAllPipelines worker_limit env all_pipelines-    atomically $ writeTVar stopped_var True-    wait_log_thread--withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a-withLocalTmpFS tmpfs act = do-  let initialiser = do-        liftIO $ forkTmpFsFrom tmpfs-      finaliser tmpfs_local = do-        liftIO $ mergeTmpFsInto tmpfs_local tmpfs-       -- Add remaining files which weren't cleaned up into local tmp fs for-       -- clean-up later.-       -- Clear the logQueue if this node had it's own log queue-  MC.bracket initialiser finaliser act--withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a-withLocalTmpFSMake env k =-  withLocalTmpFS (hsc_tmpfs (hsc_env env)) $ \lcl_tmpfs-    -> k (env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }})----- | Run the given actions and then wait for them all to finish.-runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()-runAllPipelines worker_limit env acts = do-  let single_worker = isWorkerLimitSequential worker_limit-      spawn_actions :: IO [ThreadId]-      spawn_actions = if single_worker-        then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)-        else runLoop forkIOWithUnmask env acts--      kill_actions :: [ThreadId] -> IO ()-      kill_actions tids = mapM_ killThread tids--  MC.bracket spawn_actions kill_actions $ \_ -> do-    mapM_ waitMakeAction acts---- | Execute each action in order, limiting the amount of parallelism by the given--- semaphore.-runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]-runLoop _ _env [] = return []-runLoop fork_thread env (MakeAction act res_var :acts) = do--  -- withLocalTmpFs has to occur outside of fork to remain deterministic-  new_thread <- withLocalTmpFSMake env $ \lcl_env ->-    fork_thread $ \unmask -> (do-            mres <- (unmask $ run_pipeline lcl_env act)-                      `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.-            putMVar res_var mres)-  threads <- runLoop fork_thread env acts-  return (new_thread : threads)-  where-      run_pipeline :: MakeEnv -> RunMakeM a -> IO (Maybe a)-      run_pipeline env p = runMaybeT (runReaderT p env)--data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))--waitMakeAction :: MakeAction -> IO ()-waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar--{- Note [GHC Heap Invariants]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~-This note is a general place to explain some of the heap invariants which should-hold for a program compiled with --make mode. These invariants are all things-which can be checked easily using ghc-debug.--1. No HomeModInfo are reachable via the EPS.-   Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains-        a reference to the entire HscEnv, if we are not careful the HscEnv will-        contain the HomePackageTable at the time the interface was loaded and-        it will never be released.-   Where? dontLeakTheHUG in GHC.Iface.Load--2. No KnotVars are live at the end of upsweep (#20491)-   Why? KnotVars contains an old stale reference to the TypeEnv for modules-        which participate in a loop. At the end of a loop all the KnotVars references-        should be removed by the call to typecheckLoop.-   Where? typecheckLoop in GHC.Driver.Make.--3. Immediately after a reload, no ModDetails are live.-   Why? During the upsweep all old ModDetails are replaced with a new ModDetails-        generated from a ModIface. If we don't clear the ModDetails before the-        reload takes place then memory usage during the reload is twice as much-        as it should be as we retain a copy of the ModDetails for too long.-   Where? pruneCache in GHC.Driver.Make--4. No TcGblEnv or TcLclEnv are live after typechecking is completed.-   Why? By the time we get to simplification all the data structures from typechecking-        should be eliminated.-   Where? No one place in the compiler. These leaks can be introduced by not suitable-          forcing functions which take a TcLclEnv as an argument.--5. At the end of a successful upsweep, the number of live ModDetails equals the-   number of non-boot Modules.-   Why? Each module has a HomeModInfo which contains a ModDetails from that module.-   Where? See Note [ModuleNameSet, efficiency and space leaks], a variety of places-          in the driver are responsible.+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- This module implements multi-module compilation, and is used+-- by --make and GHCi.+--+-- -----------------------------------------------------------------------------+module GHC.Driver.Make (+        depanal, depanalE, depanalPartial,+        load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,++        downsweep,++        topSortModuleGraph,++        ms_home_srcimps, ms_home_imps,++        hscSourceToIsBoot,+        findExtraSigImports,+        implicitRequirementsShallow,++        noModError, cyclicModuleErr,+        SummaryNode,+        IsBootInterface(..), mkNodeKey,++        ModNodeKey, ModNodeKeyWithUid(..),+        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith,++        -- * Re-exports from Downsweep+        checkHomeUnitsClosed,+        summariseModule,+        summariseModuleInterface,+        SummariseResult(..),+        summariseFile,++        instantiationNodes,+        ) where++import GHC.Prelude+import GHC.Platform++import GHC.Tc.Utils.Backpack+import GHC.Tc.Utils.Monad  ( initIfaceCheck, concatMapM )++import GHC.Runtime.Interpreter+import qualified GHC.Linker.Loader as Linker+import GHC.Linker.Types+++import GHC.Driver.Config.Diagnostic+import GHC.Driver.Pipeline+import GHC.Driver.Session+import GHC.Driver.DynFlags (ReexportedModule(..))+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Main+import GHC.Driver.MakeSem+import GHC.Driver.Downsweep+import GHC.Driver.MakeAction++import GHC.ByteCode.Types++import GHC.Iface.Load      ( cannotFindModule, readIface )+import GHC.IfaceToCore     ( typecheckIface )+import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )++import GHC.Data.Bag        ( listToBag )+import GHC.Data.Graph.Directed+import GHC.Data.Maybe      ( expectJust )++import GHC.Utils.Exception ( throwIO, SomeAsyncException )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.TmpFs++import GHC.Types.Basic+import GHC.Types.Error+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.PkgQual++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Graph+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.ModDetails++import qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Concurrent.MVar+import Control.Monad+import qualified Control.Monad.Catch as MC+import Data.IORef+import Data.Maybe+import Data.List (sortOn, groupBy, sortBy)+import qualified Data.List as List+import System.FilePath++import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import qualified Data.Map.Strict as M+import GHC.Types.TypeEnv+import Control.Monad.Trans.State.Lazy+import Control.Monad.Trans.Class+import GHC.Driver.Env.KnotVars+import Control.Monad.Trans.Maybe+import GHC.Runtime.Loader+import GHC.Utils.Constants+import GHC.Iface.Errors.Types+import Data.Function+import qualified GHC.Data.Maybe as M++import GHC.Data.Graph.Directed.Reachability+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Home.PackageTable++-- -----------------------------------------------------------------------------+-- Loading the program++-- | Perform a dependency analysis starting from the current targets+-- and update the session with the new module graph.+--+-- Dependency analysis entails parsing the @import@ directives and may+-- therefore require running certain preprocessors.+--+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want+-- changes to the 'DynFlags' to take effect you need to call this function+-- again.+-- In case of errors, just throw them.+--+depanal :: GhcMonad m =>+           [ModuleName]  -- ^ excluded modules+        -> Bool          -- ^ allow duplicate roots+        -> m ModuleGraph+depanal excluded_mods allow_dup_roots = do+    (errs, mod_graph) <- depanalE mkUnknownDiagnostic Nothing excluded_mods allow_dup_roots+    if isEmptyMessages errs+      then pure mod_graph+      else throwErrors (fmap GhcDriverMessage errs)++-- | Perform dependency analysis like in 'depanal'.+-- In case of errors, the errors and an empty module graph are returned.+depanalE :: GhcMonad m =>     -- New for #17459+               (GhcMessage -> AnyGhcDiagnostic)+            -> Maybe Messager+            -> [ModuleName]      -- ^ excluded modules+            -> Bool           -- ^ allow duplicate roots+            -> m (DriverMessages, ModuleGraph)+depanalE diag_wrapper msg excluded_mods allow_dup_roots = do+    hsc_env <- getSession+    (errs, mod_graph) <- depanalPartial diag_wrapper msg excluded_mods allow_dup_roots+    if isEmptyMessages errs+      then do+        hsc_env <- getSession+        let one_unit_messages get_mod_errs k hue = do+              errs <- get_mod_errs+              unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph++              let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph+                  unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph+++              return $ errs `unionMessages` unused_home_mod_err+                          `unionMessages` unused_pkg_err+                          `unionMessages` unknown_module_err++        all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)+        logDiagnostics (GhcDriverMessage <$> all_errs)+        setSession (setModuleGraph mod_graph hsc_env)+        pure (emptyMessages, mod_graph)+      else do+        -- We don't have a complete module dependency graph,+        -- The graph may be disconnected and is unusable.+        setSession (setModuleGraph emptyMG hsc_env)+        pure (errs, emptyMG)+++-- | Perform dependency analysis like 'depanal' but return a partial module+-- graph even in the face of problems with some modules.+--+-- Modules which have parse errors in the module header, failing+-- preprocessors or other issues preventing them from being summarised will+-- simply be absent from the returned module graph.+--+-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the+-- new module graph.+depanalPartial+    :: GhcMonad m+    => (GhcMessage -> AnyGhcDiagnostic)+    -> Maybe Messager+    -> [ModuleName]  -- ^ excluded modules+    -> Bool          -- ^ allow duplicate roots+    -> m (DriverMessages, ModuleGraph)+    -- ^ possibly empty 'Bag' of errors and a module graph.+depanalPartial diag_wrapper msg excluded_mods allow_dup_roots = do+  hsc_env <- getSession+  let+         targets = hsc_targets hsc_env+         old_graph = hsc_mod_graph hsc_env+         logger  = hsc_logger hsc_env++  withTiming logger (text "Chasing dependencies") (const ()) $ do+    liftIO $ debugTraceMsg logger 2 (hcat [+              text "Chasing modules from: ",+              hcat (punctuate comma (map pprTarget targets))])++    -- Home package modules may have been moved or deleted, and new+    -- source files may have appeared in the home package that shadow+    -- external package modules, so we have to discard the existing+    -- cached finder data.+    liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)++    (errs, mod_graph) <- liftIO $ downsweep+      hsc_env diag_wrapper msg (mgModSummaries old_graph)+      excluded_mods allow_dup_roots+    return (unionManyMessages errs, mod_graph)+++-- Note [Missing home modules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Sometimes we don't want GHC to process modules that weren't specified as+-- explicit targets. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns the user about modules listed+-- neither in `exposed-modules` nor in `other-modules`.+--+-- Here "home module" means a module that doesn't come from another package.+--+-- For example, if GHC is invoked with modules "A" and "B" as targets,+-- but "A" imports some other module "C", then GHC will issue a warning+-- about module "C" not being listed in the command line.+--+-- The warning in enabled by `-Wmissing-home-modules`. See #13129+warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages+warnMissingHomeModules dflags targets mod_graph =+    if null missing+      then emptyMessages+      else warn+  where+    diag_opts = initDiagOpts dflags++    -- We need to be careful to handle the case where (possibly+    -- path-qualified) filenames (aka 'TargetFile') rather than module+    -- names are being passed on the GHC command-line.+    --+    -- For instance, `ghc --make src-exe/Main.hs` and+    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.+    -- Note also that we can't always infer the associated module name+    -- directly from the filename argument.  See #13727.+    is_known_module mod =+      is_module_target mod+      ||+      maybe False is_file_target (ml_hs_file (ms_location mod))++    is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets++    is_file_target file = Set.member (withoutExt file) file_targets++    file_targets = Set.fromList (mapMaybe file_target targets)++    file_target Target {targetId} =+      case targetId of+        TargetModule _ -> Nothing+        TargetFile file _ ->+          Just (withoutExt (augmentByWorkingDirectory dflags file))++    mod_targets = Set.fromList (mod_target <$> targets)++    mod_target Target {targetUnitId, targetId} =+      case targetId of+        TargetModule name -> (name, targetUnitId)+        TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId)++    withoutExt = fst . splitExtension++    missing = map (moduleName . ms_mod) $+      filter (not . is_known_module) $+        (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+                (mgModSummaries mod_graph))++    warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ DriverMissingHomeModules (homeUnitId_ dflags) missing (checkBuildingCabalPackage dflags)++-- Check that any modules we want to reexport or hide are actually in the package.+warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages+warnUnknownModules hsc_env dflags mod_graph = do+  reexported_warns <- filterM check_reexport reexported_mods+  return $ final_msgs hidden_warns reexported_warns+  where+    diag_opts = initDiagOpts dflags++    unit_mods = Set.fromList (map ms_mod_name+                  (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+                       (mgModSummaries mod_graph)))++    reexported_mods = reexportedModules dflags+    hidden_mods     = hiddenModules dflags++    hidden_warns = hidden_mods `Set.difference` unit_mods++    lookupModule mn = findImportedModule hsc_env mn NoPkgQual++    check_reexport mn = do+      fr <- lookupModule (reexportFrom mn)+      case fr of+        Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)+        _ -> return True+++    warn diagnostic = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ diagnostic++    final_msgs hidden_warns reexported_warns+          =+        unionManyMessages $+          [warn (DriverUnknownHiddenModules (homeUnitId_ dflags) (Set.toList hidden_warns)) | not (Set.null hidden_warns)]+          ++ [warn (DriverUnknownReexportedModules (homeUnitId_ dflags) reexported_warns) | not (null reexported_warns)]++-- | Describes which modules of the module graph need to be loaded.+data LoadHowMuch+   = LoadAllTargets+     -- ^ Load all targets and its dependencies.+   | LoadUpTo [HomeUnitModule]+     -- ^ Load only the given modules and its dependencies.+     -- If empty, we load none of the targets+   | LoadDependenciesOf HomeUnitModule+     -- ^ Load only the dependencies of the given module, but not the module+     -- itself.++{-+Note [Caching HomeModInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~++API clients who call `load` like to cache the HomeModInfo in memory between+calls to this function. In the old days, this cache was a simple MVar which stored+a HomePackageTable. This was insufficient, as the interface files for boot modules+were not recorded in the cache. In the less old days, the cache was returned at the+end of load, and supplied at the start of load, however, this was not sufficient+because it didn't account for the possibility of exceptions such as SIGINT (#20780).++So now, in the current day, we have this ModIfaceCache abstraction which+can incrementally be updated during the process of upsweep. This allows us+to store interface files for boot modules in an exception-safe way.++When the final version of an interface file is completed then it is placed into+the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache.++Note that because we only store the ModIface and Linkable in the ModIfaceCache,+hydration and rehydration is totally irrelevant, and we just store the CachedIface as+soon as it is completed.++-}+++-- Abstract interface to a cache of HomeModInfo+-- See Note [Caching HomeModInfo]+data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface]+                                   , iface_addToCache :: CachedIface -> IO () }++addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()+addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l)++data CachedIface = CachedIface { cached_modiface :: !ModIface+                               , cached_linkable :: !HomeModLinkable }++instance Outputable CachedIface where+  ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln]++noIfaceCache :: Maybe ModIfaceCache+noIfaceCache = Nothing++newIfaceCache :: IO ModIfaceCache+newIfaceCache = do+  ioref <- newIORef []+  return $+    ModIfaceCache+      { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c))+      , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ()))+      }+++++-- | Try to load the program.  See 'LoadHowMuch' for the different modes.+--+-- This function implements the core of GHC's @--make@ mode.  It preprocesses,+-- compiles and loads the specified modules, avoiding re-compilation wherever+-- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling+-- and loading may result in files being created on disk.+--+-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether+-- successful or not.+--+-- If errors are encountered during dependency analysis, the module `depanalE`+-- returns together with the errors an empty ModuleGraph.+-- After processing this empty ModuleGraph, the errors of depanalE are thrown.+-- All other errors are reported using the 'defaultWarnErrLogger'.++load :: GhcMonad f => LoadHowMuch -> f SuccessFlag+load how_much = loadWithCache noIfaceCache mkUnknownDiagnostic how_much++mkBatchMsg :: HscEnv -> Messager+mkBatchMsg hsc_env =+  if length (hsc_all_home_unit_ids hsc_env) > 1+    -- This also displays what unit each module is from.+    then batchMultiMsg+    else batchMsg+++loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how to cache interfaces as we create them.+                            -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user.+                                                                -- If you are using the GHC API you can use this to override how messages+                                                                -- created during 'loadWithCache' are displayed to the user.+                            -> LoadHowMuch -- ^ How much `loadWithCache` should load+                            -> m SuccessFlag+loadWithCache cache diag_wrapper how_much = do+    msg <- mkBatchMsg <$> getSession+    (errs, mod_graph) <- depanalE diag_wrapper (Just msg) [] False                        -- #17459+    success <- load' cache how_much diag_wrapper (Just msg) mod_graph+    if isEmptyMessages errs+      then pure success+      else throwErrors (fmap GhcDriverMessage errs)++-- Note [Unused packages]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- Cabal passes `-package-id` flag for each direct dependency. But GHC+-- loads them lazily, so when compilation is done, we have a list of all+-- actually loaded packages. All the packages, specified on command line,+-- but never loaded, are probably unused dependencies.++warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages+warnUnusedPackages us dflags mod_graph =+    let diag_opts = initDiagOpts dflags++        home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)++    -- Only need non-source imports here because SOURCE imports are always HPT+        loadedPackages = concat $+          mapMaybe (\(_st, fs, mn) -> lookupModulePackage us (unLoc mn) fs)+            $ concatMap ms_imps home_mod_sum++        used_args = Set.fromList (map unitId loadedPackages)++        resolve (u,mflag) = do+                  -- The units which we depend on via the command line explicitly+                  flag <- mflag+                  -- Which we can find the UnitInfo for (should be all of them)+                  ui <- lookupUnit us u+                  -- Which are not explicitly used+                  guard (Set.notMember (unitId ui) used_args)+                  return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)++        unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us)++        warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)++    in if null unusedArgs+        then emptyMessages+        else warn++-- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any+-- path from module to its boot file.+data ModuleGraphNodeWithBootFile+  = ModuleGraphNodeWithBootFile+     ModuleGraphNode+       -- ^ The module itself (not the hs-boot module)+     [NodeKey]+       -- ^ The modules in between the module and its hs-boot file,+       -- not including the hs-boot file itself.+++instance Outputable ModuleGraphNodeWithBootFile where+  ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps++-- | A 'BuildPlan' is the result of attempting to linearise a single strongly-connected+-- component of the module graph.+data BuildPlan+  -- | A simple, single module all alone (which *might* have an hs-boot file, if it isn't part of a cycle)+  = SingleModule ModuleGraphNode+  -- | A resolved cycle, linearised by hs-boot files+  | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]+  -- | An actual cycle, which wasn't resolved by hs-boot files+  | UnresolvedCycle [ModuleGraphNode]++instance Outputable BuildPlan where+  ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)+  ppr (ResolvedCycle mgn)   = text "ResolvedCycle:" <+> ppr mgn+  ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn+++-- Just used for an assertion+countMods :: BuildPlan -> Int+countMods (SingleModule _) = 1+countMods (ResolvedCycle ns) = length ns+countMods (UnresolvedCycle ns) = length ns++-- See Note [Upsweep] for a high-level description.+createBuildPlan :: ModuleGraph -> Maybe [HomeUnitModule] -> [BuildPlan]+createBuildPlan mod_graph maybe_top_mod =+    let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles+        cycle_mod_graph   = topSortModuleGraph True  mod_graph maybe_top_mod+        acyclic_mod_graph = topSortModuleGraph False mod_graph maybe_top_mod++        -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.+        build_plan :: [BuildPlan]+        build_plan+          -- Fast path, if there are no boot modules just do a normal toposort+          | isEmptyModuleEnv boot_modules = collapseAcyclic acyclic_mod_graph+          | otherwise = toBuildPlan cycle_mod_graph []++        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]+        toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)+        toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)+        -- Interesting case+        toBuildPlan ((CyclicSCC nodes):sccs) mgn =+          let acyclic = collapseAcyclic (topSortWithBoot mgn)+              -- Now perform another toposort but just with these nodes and relevant hs-boot files.+              -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.+              mresolved_cycle = collapseSCC (topSortWithBoot nodes)+          in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []++        -- Compute the intermediate modules between a file and its hs-boot file.+        -- See Step 2a in Note [Upsweep]+        boot_path mn uid =+          Set.toList $+          -- Don't include the boot module itself+          Set.filter ((/= NodeKey_Module (key IsBoot)) . mkNodeKey)  $+          -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are+          -- the transitive dependencies of the non-boot file which transitively depend+          -- on the boot file.+          Set.filter (\(mkNodeKey -> nk) ->+            nodeKeyUnitId nk == uid  -- Cheap test+              && mgQuery mod_graph nk (NodeKey_Module (key IsBoot))) $+          Set.fromList $+          expectJust (mgReachable mod_graph (NodeKey_Module (key NotBoot)))+          where+            key ib = ModNodeKeyWithUid (GWIB mn ib) uid+++        -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists+        boot_modules = mkModuleEnv+          [ (mn, (m, boot_path (moduleName mn) (moduleUnitId mn)))+            | m@(ModuleNode _ ms) <- mgModSummaries' mod_graph+            , let mn = moduleNodeInfoModule ms+            , isBootModuleNodeInfo ms == IsBoot]++        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]+        select_boot_modules = mapMaybe (fmap fst . get_boot_module)++        get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])+        get_boot_module (ModuleNode _ ms)+          | NotBoot <- isBootModuleNodeInfo ms+          = lookupModuleEnv boot_modules (moduleNodeInfoModule ms)+        get_boot_module _ = Nothing++        -- Any cycles should be resolved now+        collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]+        -- Must be at least two nodes, as we were in a cycle+        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2]+        collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes)+        -- Cyclic+        collapseSCC nodes = Left (flattenSCCs nodes)++        toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile+        toNodeWithBoot mn =+          case get_boot_module mn of+            -- The node doesn't have a boot file+            Nothing -> Left mn+            -- The node does have a boot file+            Just path -> Right (ModuleGraphNodeWithBootFile mn (map mkNodeKey (snd path)))++        -- The toposort and accumulation of acyclic modules is solely to pick-up+        -- hs-boot files which are **not** part of cycles.+        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]+        collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes+        collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes+        collapseAcyclic [] = []++        topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing+  in+    -- We need to use 'acyclic_mod_graph', since if 'maybe_top_mod' is 'Just', then the resulting module+    -- graph is pruned, reducing the number of 'build_plan' elements.+    -- We don't use the size of 'cycle_mod_graph', as it removes @.hi-boot@ modules. These are added+    -- later in the processing.+    assertPpr (sum (map countMods build_plan) == lengthMGWithSCC acyclic_mod_graph)+              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC acyclic_mod_graph))])+              build_plan+  where+    lengthMGWithSCC :: [SCC a] -> Int+    lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0++-- | Generalized version of 'load' which also supports a custom+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally+-- produced by calling 'depanal'.+load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do+    -- In normal usage plugins are initialised already by ghc/Main.hs this is protective+    -- for any client who might interact with GHC via load'.+    -- See Note [Timing of plugin initialization]+    initializeSessionPlugins+    modifySession (setModuleGraph mod_graph)+    guessOutputFile+    hsc_env <- getSession++    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let interp = hscInterp hsc_env++    -- The "bad" boot modules are the ones for which we have+    -- B.hs-boot in the module graph, but no B.hs+    -- The downsweep should have ensured this does not happen+    -- (see msDeps)+    let all_home_mods =+          Set.fromList [ Module (ms_unitid s) (ms_mod_name s)+                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]+    -- TODO: Figure out what the correct form of this assert is. It's violated+    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot+    -- 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 ()++    -- check that the module given in HowMuch actually exists, otherwise+    -- topSortModuleGraph will bomb later.+    let checkHowMuch (LoadUpTo ms)          = checkMods ms+        checkHowMuch (LoadDependenciesOf m) = checkMods [m]+        checkHowMuch _ = id++        checkMods ms and_then =+          case List.partition (`Set.member` all_home_mods) ms of+            (_, []) -> and_then+            (_, not_found_mods) -> do+              let+                mkModuleNotFoundError m =+                  mkPlainErrorMsgEnvelope noSrcSpan+                  $ GhcDriverMessage+                  $ DriverModuleNotFound (moduleUnit m) (moduleName m)+              throwErrors $ mkMessages $ listToBag [mkModuleNotFoundError not_found | not_found <- not_found_mods]++    checkHowMuch how_much $ do++    -- mg2_with_srcimps drops the hi-boot nodes, returning a+    -- graph with cycles. It is just used for warning about unnecessary source imports.+    let mg2_with_srcimps :: [SCC ModuleGraphNode]+        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing++    -- If we can determine that any of the {-# SOURCE #-} imports+    -- are definitely unnecessary, then emit a warning.+    warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)++    let maybe_top_mods = case how_much of+                          LoadUpTo m           -> Just m+                          LoadDependenciesOf m -> Just [m]+                          _                    -> Nothing++        build_plan = createBuildPlan mod_graph maybe_top_mods+++    cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache+    let+        -- prune the HPT so everything is not retained when doing an+        -- upsweep.+        !pruned_cache = pruneCache cache+                            [ms | (ModuleNodeCompile ms) <- (flattenSCCs (filterToposortToModules  mg2_with_srcimps))]++++    -- before we unload anything, make sure we don't leave an old+    -- interactive context around pointing to dead bindings.  Also,+    -- write an empty HPT to allow the old HPT to be GC'd.++    let pruneHomeUnitEnv hme = do+          emptyHPT <- liftIO emptyHomePackageTable+          pure $! hme{ homeUnitEnv_hpt = emptyHPT }+    hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph $ hsc_unit_env hsc_env)+    let ue' = (hsc_unit_env hsc_env){ ue_home_unit_graph = hug' }+    setSession $ discardIC hsc_env{hsc_unit_env = ue' }+    hsc_env <- getSession++    -- Unload everything+    liftIO $ unload interp hsc_env++    liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")+                                    2 (ppr build_plan))++    worker_limit <- liftIO $ mkWorkerLimit dflags++    (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do+      hsc_env <- getSession+      liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan++    -- At this point, all the HPT variables will be populated, but we don't want+    -- to leak the contents of a failed session.+    liftIO $ restrictDepsHscEnv new_deps hsc_env+    case upsweep_ok of+      Failed -> loadFinish upsweep_ok+      Succeeded -> do+          liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")+          loadFinish upsweep_ok++++-- | Finish up after a load.+loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag+-- Empty the interactive context and set the module context to the topmost+-- newly loaded module, or the Prelude if none were loaded.+loadFinish all_ok+  = do modifySession discardIC+       return all_ok+++-- | If there is no -o option, guess the name of target executable+-- by using top-level source file name as a base.+guessOutputFile :: GhcMonad m => m ()+guessOutputFile = modifySession $ \env ->+    -- Force mod_graph to avoid leaking env+    let !mod_graph = hsc_mod_graph env+        new_home_graph =+          flip fmap (hsc_HUG env) $ \hue ->+            let dflags = homeUnitEnv_dflags hue+                platform = targetPlatform dflags+                mainModuleSrcPath :: Maybe String+                mainModuleSrcPath = do+                  ms <- mgLookupModule mod_graph (mainModIs hue)+                  ml_hs_file (moduleNodeInfoLocation ms)+                name = fmap dropExtension mainModuleSrcPath++                -- MP: This exception is quite sensitive to being forced, if you+                -- force it here then the error message is different because it gets+                -- caught by a different error handler than the test (T9930fail) expects.+                -- Putting an exception into DynFlags is probably not a great design but+                -- I'll write this comment rather than more eagerly force the exception.+                name_exe = do+                  -- 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' <- case platformArchOS platform of+                             ArchOS _ OSMinGW32  -> fmap (<.> "exe") name+                             ArchOS ArchWasm32 _ -> fmap (<.> "wasm") name+                             _ -> name+                 mainModuleSrcPath' <- mainModuleSrcPath+                 -- #9930: don't clobber input files (unless they ask for it)+                 if name' == mainModuleSrcPath'+                   then throwGhcException . UsageError $+                        "default output name would overwrite the input file; " +++                        "must specify -o explicitly"+                   else Just name'+            in+              case outputFile_ dflags of+                Just _ -> hue+                Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }+    in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }++-- -----------------------------------------------------------------------------+--+-- | Prune the HomePackageTable+--+-- Before doing an upsweep, we can throw away:+--+--   - all ModDetails, all linked code+--   - all unlinked code that is out of date with respect to+--     the source file+--+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the+-- space at the end of the upsweep, because the topmost ModDetails of the+-- old HPT holds on to the entire type environment from the previous+-- compilation.+-- Note [GHC Heap Invariants]+pruneCache :: [CachedIface]+                      -> [ModSummary]+                      -> [HomeModInfo]+pruneCache hpt summ+  = strictMap prune hpt+  where prune (CachedIface { cached_modiface = iface+                           , cached_linkable = linkable+                           }) = HomeModInfo iface emptyModDetails linkable'+          where+           modl = miKey iface+           linkable'+                | Just ms <- M.lookup modl ms_map+                , mi_src_hash iface == Just (ms_hs_hash ms)+                = linkable+                | otherwise+                = emptyHomeModInfoLinkable++        -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error.+        ms_map = M.fromListWith+                  (\ms1 ms2 -> assertPpr False (text "prune_cache" $$ (ppr ms1 <+> ppr ms2))+                               ms2)+                  [(msKey ms, ms) | ms <- summ]++-- ---------------------------------------------------------------------------+--+-- | Unloading+unload :: Interp -> HscEnv -> IO ()+unload interp hsc_env+  = case ghcLink (hsc_dflags hsc_env) of+        LinkInMemory -> Linker.unload interp hsc_env []+        _other -> return ()+++{- Parallel Upsweep++The parallel upsweep attempts to concurrently compile the modules in the+compilation graph using multiple Haskell threads.++The Algorithm++* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is+a pair of an `IO a` action and a `MVar a`, where to place the result.+  The list is sorted topologically, so can be executed in order without fear of+  blocking.+* runPipelines takes this list and eventually passes it to runLoop which executes+  each action and places the result into the right MVar.+* The amount of parallelism is controlled by a semaphore. This is just used around the+  module compilation step, so that only the right number of modules are compiled at+  the same time which reduces overall memory usage and allocations.+* Each proper node has a LogQueue, which dictates where to send it's output.+* The LogQueue is placed into the LogQueueQueue when the action starts and a worker+  thread processes the LogQueueQueue printing logs for each module in a stable order.+* The result variable for an action producing `a` is of type `Maybe a`, therefore+  it is still filled on a failure. If a module fails to compile, the+  failure is propagated through the whole module graph and any modules which didn't+  depend on the failure can still be compiled. This behaviour also makes the code+  quite a bit cleaner.+-}+++{-++Note [--make mode]+~~~~~~~~~~~~~~~~~+There are two main parts to `--make` mode.++1. `downsweep`: Starts from the top of the module graph and computes dependencies.+2. `upsweep`: Starts from the bottom of the module graph and compiles modules.++The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which+computers how to build this ModuleGraph.++Note [Upsweep]+~~~~~~~~~~~~~~+Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes+the plan in order to compile the project.++The first step is computing the build plan from a 'ModuleGraph'.++The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for+how to build all the modules.++```+data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle+               | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot]   -- A resolved cycle, linearised by hs-boot files+               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files+```++The plan is computed in two steps:++Step 1:  Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains+         cycles.+Step 2:  For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should+         result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.+Step 2a: For each module in the cycle, if the module has a boot file then compute the+         modules on the path between it and the hs-boot file.+         These are the intermediate modules which:+            (1) are (transitive) dependencies of the non-boot module, and+            (2) have the boot module as a (transitive) dependency.+         In particular, all such intermediate modules must appear in the same unit as+         the module under consideration, as module cycles cannot cross unit boundaries.+         This information is stored in ModuleGraphNodeWithBoot.++The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.++* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.+* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented+  with a consistent knot-tied version of modules at the end.+    - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration+      is performed both before and after the module in question is compiled.+      See Note [Hydrating Modules] for more information.+* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files+  and are reported as an error to the user.++The main trickiness of `interpretBuildPlan` is deciding which version of a dependency+is visible from each module. For modules which are not in a cycle, there is just+one version of a module, so that is always used. For modules in a cycle, there are two versions of+'HomeModInfo'.++1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.+2. External to loop: The knot-tied version created by typecheckLoop.++Whilst compiling a module inside the loop, we need to use the (1). For a module which+is outside of the loop which depends on something from in the loop, the (2) version+is used.++As the plan is interpreted, which version of a HomeModInfo is visible is updated+by updating a map held in a state monad. So after a loop has finished being compiled,+the visible module is the one created by typecheckLoop and the internal version is not+used again.++This plan also ensures the most important invariant to do with module loops:++> If you depend on anything within a module loop, before you can use the dependency,+  the whole loop has to finish compiling.++The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs+of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running+the action. This list is topologically sorted, so can be run in order to compute+the whole graph.++As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which+can be queried at the end to get the result of all modules at the end, with their proper+visibility. For example, if any module in a loop fails then all modules in that loop will+report as failed because the visible node at the end will be the result of checking+these modules together.++-}++-- | Simple wrapper around MVar which allows a functor instance.+data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))++deriving instance Functor ResultVar++mkResultVar :: MVar (Maybe a) -> ResultVar a+mkResultVar = ResultVar id++-- | Block until the result is ready.+waitResult :: ResultVar a -> MaybeT IO a+waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)++data BuildResult = BuildResult { _resultOrigin :: ResultOrigin+                               , resultVar    :: ResultVar (Maybe HomeModInfo)+                               }++-- The origin of this result var, useful for debugging+data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Show)++data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Show)++mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult+mkBuildResult = BuildResult+++data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey BuildResult+                                          -- The current way to build a specific TNodeKey, without cycles this just points to+                                          -- the appropriate result of compiling a module  but with+                                          -- cycles there can be additional indirection and can point to the result of typechecking a loop+                                     , nNODE :: Int+                                     }++nodeId :: BuildM Int+nodeId = do+  n <- gets nNODE+  modify (\m -> m { nNODE = n + 1 })+  return n+++setModulePipeline :: NodeKey -> BuildResult -> BuildM ()+setModulePipeline mgn build_result = do+  modify (\m -> m { buildDep = M.insert mgn build_result (buildDep m) })++type BuildMap = M.Map NodeKey BuildResult++getBuildMap :: BuildM BuildMap+getBuildMap = gets buildDep++getDependencies :: [NodeKey] -> BuildMap -> [BuildResult]+getDependencies direct_deps build_map =+  strictMap (expectJust . flip M.lookup build_map) direct_deps++type BuildM a = StateT BuildLoopState IO a+++++-- | Given the build plan, creates a graph which indicates where each NodeKey should+-- get its direct dependencies from. This might not be the corresponding build action+-- if the module participates in a loop. This step also labels each node with a number for the output.+-- See Note [Upsweep] for a high-level description.+interpretBuildPlan :: HomeUnitGraph+                   -> Maybe ModIfaceCache+                   -> M.Map ModNodeKeyWithUid HomeModInfo+                   -> [BuildPlan]+                   -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle+                         , [MakeAction] -- Actions we need to run in order to build everything+                         , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.+interpretBuildPlan hug mhmi_cache old_hpt plan = do+  ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1)+  let wait = collect_results (buildDep build_map)+  return (mcycle, plans, wait)++  where+    collect_results build_map =+      sequence (map (\br -> collect_result (resultVar br)) (M.elems build_map))+      where+        collect_result res_var = runMaybeT (waitResult res_var)++    -- Just used for an assertion+    count_mods :: BuildPlan -> Int+    count_mods (SingleModule m) = count_m m+    count_mods (ResolvedCycle ns) = length ns+    count_mods (UnresolvedCycle ns) = length ns++    count_m (UnitNode {}) = 0+    count_m _ = 1++    n_mods = sum (map count_mods plan)++    buildLoop :: [BuildPlan]+              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])+    -- Build the abstract pipeline which we can execute+    -- Building finished+    buildLoop []           = return (Nothing, [])+    buildLoop (plan:plans) =+      case plan of+        -- If there was no cycle, then typecheckLoop is not necessary+        SingleModule m -> do+          one_plan <- buildSingleModule Nothing NoLoop m+          (cycle, all_plans) <- buildLoop plans+          return (cycle, one_plan : all_plans)++        -- For a resolved cycle, depend on everything in the loop, then update+        -- the cache to point to this node rather than directly to the module build+        -- nodes+        ResolvedCycle ms -> do+          pipes <- buildModuleLoop ms+          (cycle, graph) <- buildLoop plans+          return (cycle, pipes ++ graph)++        -- Can't continue past this point as the cycle is unresolved.+        UnresolvedCycle ns -> return (Just ns, [])++    buildSingleModule :: Maybe [NodeKey]  -- Modules we need to rehydrate before compiling this module+                      -> ResultOrigin+                      -> ModuleGraphNode          -- The node we are compiling+                      -> BuildM MakeAction+    buildSingleModule rehydrate_nodes origin mod = do+      !build_map <- getBuildMap+      -- 1. Get the direct dependencies of this module+      let direct_deps = mgNodeDependencies False mod+          -- It's really important to force build_deps, or the whole buildMap is retained,+          -- which would retain all the result variables, preventing us from collecting them+          -- after they are no longer used.+          !build_deps = getDependencies direct_deps build_map+      !build_action <-+            case mod of+              InstantiationNode uid iu -> do+                mod_idx <- nodeId+                return $ withCurrentUnit (mgNodeUnitId mod) $ do+                  !_ <- wait_deps build_deps+                  executeInstantiationNode mod_idx n_mods hug uid iu+                  return Nothing+              ModuleNode _build_deps ms -> do+                let !old_hmi = M.lookup (mnKey ms) old_hpt+                    rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes+                mod_idx <- nodeId+                return $ withCurrentUnit (mgNodeUnitId mod) $ do+                     !_ <- wait_deps build_deps+                     hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms+                     -- Write the HMI to an external cache (if one exists)+                     -- See Note [Caching HomeModInfo]+                     liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi+                     -- Make sure the result is written to the HPT var+                     liftIO $ HUG.addHomeModInfoToHug hmi hug+                     return (Just hmi)+              LinkNode _nks uid -> do+                  mod_idx <- nodeId+                  return $ withCurrentUnit (mgNodeUnitId mod) $ do+                    !_ <- wait_deps build_deps+                    executeLinkNode hug (mod_idx, n_mods) uid direct_deps+                    return Nothing+              UnitNode {} -> return $ return Nothing+++      res_var <- liftIO newEmptyMVar+      let result_var = mkResultVar res_var+      setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var)+      return $! (MakeAction build_action res_var)+++    buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]+    buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) = do+      ma <- buildSingleModule (Just deps) (Loop Initialise) mn+      -- Rehydration (1) from Note [Hydrating Modules], "Loops with multiple boot files"+      rehydrate_action <- rehydrateAction Rehydrated ((GWIB (mkNodeKey mn) IsBoot) : (map (\d -> GWIB d NotBoot) deps))+      return $ [ma, rehydrate_action]+++    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction]+    buildModuleLoop ms = do+      build_modules <- concatMapM (either (fmap (:[]) <$> buildSingleModule Nothing (Loop Initialise)) buildOneLoopyModule) ms+      let extract (Left mn) = GWIB (mkNodeKey mn) NotBoot+          extract (Right (ModuleGraphNodeWithBootFile mn _)) = GWIB (mkNodeKey mn) IsBoot+      let loop_mods = map extract ms+      -- Rehydration (2) from Note [Hydrating Modules], "Loops with multiple boot files"+      -- Fixes the space leak described in that note.+      rehydrate_action <- rehydrateAction Finalised loop_mods++      return $ build_modules ++ [rehydrate_action]++    -- An action which rehydrates the given keys+    rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction+    rehydrateAction origin deps = do+      !build_map <- getBuildMap+      res_var <- liftIO newEmptyMVar+      let loop_unit :: UnitId+          !loop_unit = nodeKeyUnitId (gwib_mod (head deps))+          !build_deps = getDependencies (map gwib_mod deps) build_map+      let loop_action = withCurrentUnit loop_unit $ do+            !_ <- wait_deps build_deps+            hsc_env <- asks hsc_env+            let mns :: [ModuleName]+                mns = mapMaybe (nodeKeyModName . gwib_mod) deps++            hmis' <- liftIO $ rehydrateAfter hsc_env mns++            checkRehydrationInvariant hmis' deps++            -- Add hydrated interfaces to global variable+            liftIO $ mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi hug) hmis'+            return hmis'++      let fanout i = Just . (!! i) <$> mkResultVar res_var+      -- From outside the module loop, anyone must wait for the loop to finish and then+      -- use the result of the rehydrated iface. This makes sure that things not in the+      -- module loop will see the updated interfaces for all the identifiers in the loop.+          boot_key :: NodeKey -> NodeKey+          boot_key (NodeKey_Module m) = NodeKey_Module (m { mnkModuleName = (mnkModuleName m) { gwib_isBoot = IsBoot } } )+          boot_key k = pprPanic "boot_key" (ppr k)++          update_module_pipeline (m, i) =+            case gwib_isBoot m of+              NotBoot -> setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i))+              IsBoot -> do+                setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i))+                -- SPECIAL: Anything outside the loop needs to see A rather than A.hs-boot+                setModulePipeline (boot_key (gwib_mod m)) (mkBuildResult (Loop origin) (fanout i))++      let deps_i = zip deps [0..]+      mapM update_module_pipeline deps_i++      return $ MakeAction loop_action res_var++      -- Checks that the interfaces returned from hydration match-up with the names of the+      -- modules which were fed into the function.+    checkRehydrationInvariant hmis deps =+        let hmi_names = map (moduleName . mi_module . hm_iface) hmis+            start = mapMaybe (nodeKeyModName . gwib_mod) deps+        in massertPpr (hmi_names == start) $ (ppr hmi_names $$ ppr start)+++withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a+withCurrentUnit uid = do+  local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})++upsweep+    :: WorkerLimit -- ^ The number of workers we wish to run in parallel+    -> HscEnv -- ^ The base HscEnv, which is augmented for each module+    -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to+    -> (GhcMessage -> AnyGhcDiagnostic)+    -> Maybe Messager+    -> M.Map ModNodeKeyWithUid HomeModInfo+    -> [BuildPlan]+    -> IO (SuccessFlag, [HomeModInfo])+upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = do+    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan+    runPipelines n_jobs hsc_env diag_wrapper mHscMessage pipelines+    res <- collect_result++    let completed = [m | Just (Just m) <- res]++    -- Handle any cycle in the original compilation graph and return the result+    -- of the upsweep.+    case cycle of+        Just mss -> do+          throwOneError $ cyclicModuleErr mss+        Nothing  -> do+          let success_flag = successIf (all isJust res)+          return (success_flag, completed)++toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo+toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])++upsweep_inst :: HscEnv+             -> Maybe Messager+             -> Int  -- index of module+             -> Int  -- total number of modules+             -> UnitId+             -> InstantiatedUnit+             -> IO ()+upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do+        case mHscMessage of+            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid)+            Nothing -> return ()+        runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid+        pure ()++-- | Compile a single module.  Always produce a Linkable for it if+-- successful.  If no compilation happened, return the old Linkable.+upsweep_mod :: HscEnv+            -> Maybe Messager+            -> Maybe HomeModInfo+            -> ModSummary+            -> Int  -- index of module+            -> Int  -- total number of modules+            -> IO HomeModInfo+upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods =  do+  hmi <- compileOne' mHscMessage hsc_env summary+          mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi)++  -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module+  -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I+  -- am unsure if this is sound (wrt running TH splices for example).+  -- This function only does anything if the linkable produced is a BCO, which+  -- used to only happen with the bytecode backend, but with+  -- @-fprefer-byte-code@, @HomeModInfo@ has bytecode even when generating+  -- object code, see #25230.+  hscInsertHPT hmi hsc_env+  addSptEntries (hsc_env)+                (homeModInfoByteCode hmi)++  return hmi++-- | Add the entries from a BCO linkable to the SPT table, see+-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.+addSptEntries :: HscEnv -> Maybe Linkable -> IO ()+addSptEntries hsc_env mlinkable =+  hscAddSptEntries hsc_env+     [ spt+     | linkable <- maybeToList mlinkable+     , bco <- linkableBCOs linkable+     , spt <- bc_spt_entries bco+     ]+++-- Note [When source is considered modified]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- A number of functions in GHC.Driver accept a SourceModified argument, which+-- is part of how GHC determines whether recompilation may be avoided (see the+-- definition of the SourceModified data type for details).+--+-- Determining whether or not a source file is considered modified depends not+-- only on the source file itself, but also on the output files which compiling+-- that module would produce. This is done because GHC supports a number of+-- flags which control which output files should be produced, e.g. -fno-code+-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the+-- source file has been modified since the last compile, but also whether the+-- source file has been modified since the last compile which produced all of+-- the output files which have been requested.+--+-- Specifically, a source file is considered unmodified if it is up-to-date+-- relative to all of the output files which have been requested. Whether or+-- not an output file is up-to-date depends on what kind of file it is:+--+-- * iface (.hi) files are considered up-to-date if (and only if) their+--   mi_src_hash field matches the hash of the source file,+--+-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date+--   if (and only if) their modification times on the filesystem are greater+--   than or equal to the modification time of the corresponding .hi file.+--+-- Why do we use '>=' rather than '>' for output files other than the .hi file?+-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a+-- resolution of 2 seconds), we may often find that the .hi and .o files have+-- the same modification time. Using >= is slightly unsafe, but it matches+-- make's behaviour.+--+-- This strategy allows us to do the minimum work necessary in order to ensure+-- that all the files the user cares about are up-to-date; e.g. we should not+-- worry about .o files if the user has indicated that they are not interested+-- in them via -fno-code. See also #9243.+--+-- Note that recompilation avoidance is dependent on .hi files being produced,+-- which does not happen if -fno-write-interface -fno-code is passed. That is,+-- passing -fno-write-interface -fno-code means that you cannot benefit from+-- recompilation avoidance. See also Note [-fno-code mode].+--+-- The correctness of this strategy depends on an assumption that whenever we+-- are producing multiple output files, the .hi file is always written first.+-- If this assumption is violated, we risk recompiling unnecessarily by+-- incorrectly regarding non-.hi files as outdated.+--++-- ---------------------------------------------------------------------------+--+-- | Topological sort of the module graph+topSortModuleGraph+          :: Bool+          -- ^ Drop hi-boot nodes? (see below)+          -> ModuleGraph+          -> Maybe [HomeUnitModule]+             -- ^ Root module name.  If @Nothing@, use the full graph.+          -> [SCC ModuleGraphNode]+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes+-- The resulting list of strongly-connected-components is in topologically+-- sorted order, starting with the module(s) at the bottom of the+-- dependency graph (ie compile them first) and ending with the ones at+-- the top.+--+-- Drop hi-boot nodes (first boolean arg)?+--+-- - @False@:   treat the hi-boot summaries as nodes of the graph,+--              so the graph must be acyclic+--+-- - @True@:    eliminate the hi-boot nodes, and instead pretend+--              the a source-import of Foo is an import of Foo+--              The resulting graph has no hi-boot nodes, but can be cyclic+topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =+  topSortModules drop_hs_boot_nodes+    (sortBy (cmpModuleGraphNodes `on` mkNodeKey) $ mgModSummaries' module_graph)+    mb_root_mod+++  where+    -- In order to get the "right" ordering+    --    Module nodes must be in reverse lexigraphic order.+    --    All modules nodes must appear before package nodes.+    --+    -- MP: This is just the ordering which the tests needed in Jan 2025, it does+    --     not arise from nature.+    --+    -- Given the current implementation of scc, the result is in+    -- The order is sensitive to the internal implementation in Data.Graph,+    -- if it changes in future then this ordering will need to be modified.+    --+    -- The SCC algorithm firstly transposes the input graph and then+    -- performs dfs on the vertices in the order which they are originally given.+    -- Therefore, if `ExternalUnit` nodes are first, the order returned will+    -- be determined by the order the dependencies are stored in the transposed graph.+    moduleGraphNodeRank :: NodeKey -> Int+    moduleGraphNodeRank k =+      case k of+        NodeKey_Unit {}         -> 0+        NodeKey_Module {}       -> 1+        NodeKey_Link {}         -> 2+        NodeKey_ExternalUnit {} -> 3++    cmpModuleGraphNodes k1 k2 = compare (moduleGraphNodeRank k1) (moduleGraphNodeRank k2)+                                  `mappend` compare k2 k1++topSortModules :: Bool -> [ModuleGraphNode] -> Maybe [HomeUnitModule] -> [SCC ModuleGraphNode]+topSortModules drop_hs_boot_nodes summaries mb_root_mod+  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph+  where+    (graph, lookup_node) =+      moduleGraphNodes drop_hs_boot_nodes summaries++    initial_graph = case mb_root_mod of+        Nothing -> graph+        Just mods ->+            -- restrict the graph to just those modules reachable from+            -- the specified module.  We do this by building a graph with+            -- the full set of nodes, and determining the reachable set from+            -- the specified node.+            let+              findNodeForModule (Module uid root_mod)+                | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid+                , graph `hasVertexG` node+                = seq node node+                | otherwise+                = throwGhcException (ProgramError "module does not exist")+              roots = fmap findNodeForModule mods+            in graphFromEdgedVerticesUniq (seq roots (roots ++ allReachableMany (graphReachability graph) roots))++newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }+  deriving (Functor, Traversable, Foldable)++emptyModNodeMap :: ModNodeMap a+emptyModNodeMap = ModNodeMap Map.empty++modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a+modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)++modNodeMapElems :: ModNodeMap a -> [a]+modNodeMapElems (ModNodeMap m) = Map.elems m++modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a+modNodeMapLookup k (ModNodeMap m) = Map.lookup k m++modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a+modNodeMapSingleton k v = ModNodeMap (M.singleton k v)++modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a+modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n)++-- | If there are {-# SOURCE #-} imports between strongly connected+-- components in the topological sort, then those imports can+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE+-- were necessary, then the edge would be part of a cycle.+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModuleNodeInfo] -> m ()+warnUnnecessarySourceImports sccs = do+  diag_opts <- initDiagOpts <$> getDynFlags+  when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do+    let check ms =+           let mods_in_this_cycle = map moduleNodeInfoModuleName ms in+           [ warn i | (ModuleNodeCompile m) <- ms, i <- ms_home_srcimps m,+                      unLoc i `notElem`  mods_in_this_cycle ]++        warn :: Located ModuleName -> MsgEnvelope GhcMessage+        warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts+                                                  loc (DriverUnnecessarySourceImports mod)+    logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))+++-----------------------------------------------------------------------------+--                      Error messages+-----------------------------------------------------------------------------++-- Defer and group warning, error and fatal messages so they will not get lost+-- in the regular output.+withDeferredDiagnostics :: GhcMonad m => m a -> m a+withDeferredDiagnostics f = do+  dflags <- getDynFlags+  if not $ gopt Opt_DeferDiagnostics dflags+  then f+  else do+    warnings <- liftIO $ newIORef []+    errors <- liftIO $ newIORef []+    fatals <- liftIO $ newIORef []+    logger <- getLogger++    let deferDiagnostics _dflags !msgClass !srcSpan !msg = do+          let action = logMsg logger msgClass srcSpan msg+          case msgClass of+            MCDiagnostic SevWarning _reason _code+              -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ())+            MCDiagnostic SevError _reason _code+              -> atomicModifyIORef' errors   $ \(!i) -> (action: i, ())+            MCFatal+              -> atomicModifyIORef' fatals   $ \(!i) -> (action: i, ())+            _ -> action++        printDeferredDiagnostics = liftIO $+          forM_ [warnings, errors, fatals] $ \ref -> do+            -- This IORef can leak when the dflags leaks, so let us always+            -- reset the content. The lazy variant is used here as we want to force+            -- this error if the IORef is ever accessed again, rather than now.+            -- See #20981 for an issue which discusses this general issue.+            let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else []+            actions <- atomicModifyIORef ref $ \i -> (landmine, i)+            sequence_ $ reverse actions++    MC.bracket+      (pushLogHookM (const deferDiagnostics))+      (\_ -> popLogHookM >> printDeferredDiagnostics)+      (\_ -> f)++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 $+    DriverInterfaceError $+    (Can'tFindInterface (cannotFindModule hsc_env wanted_mod err) (LookingForModule wanted_mod NotBoot))++{-+noHsFileErr :: SrcSpan -> String -> DriverMessages+noHsFileErr loc path+  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)+  -}++++cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage+-- From a strongly connected component we find+-- a single cycle to report+cyclicModuleErr mss+  = assert (not (null mss)) $+    case findCycle graph of+       Nothing   -> pprPanic "Unexpected non-cycle" (ppr mss)+       Just path -> mkPlainErrorMsgEnvelope src_span $+                    GhcDriverMessage $ DriverModuleGraphCycle path+        where+          src_span = maybe noSrcSpan (mkFileSrcSpan . moduleNodeInfoLocation) (mgNodeIsModule (head path))+  where+    graph :: [Node NodeKey ModuleGraphNode]+    graph =+      [ DigraphNode+        { node_payload = ms+        , node_key = mkNodeKey ms+        , node_dependencies = mgNodeDependencies False ms+        }+      | ms <- mss+      ]++cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()+cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =+  if gopt Opt_KeepTmpFiles dflags+    then liftIO $ keepCurrentModuleTempFiles logger tmpfs+    else liftIO $ cleanCurrentModuleTempFiles logger tmpfs+++-- | Thin each HPT variable to only contain keys from the given dependencies.+-- This is used at the end of upsweep to make sure that only completely successfully loaded+-- modules are visible for subsequent operations.+restrictDepsHscEnv :: [HomeModInfo] -> HscEnv -> IO ()+restrictDepsHscEnv deps hsc_env =+  let deps_with_unit = map (\xs -> (fst (head xs), map snd xs)) $ groupBy ((==) `on` fst) (sortOn fst (map go deps))+      hug = ue_home_unit_graph $ hsc_unit_env hsc_env+      go hmi = (hmi_unit, hmi)+        where+          hmi_mod  = mi_module (hm_iface hmi)+          hmi_unit = toUnitId (moduleUnit hmi_mod)+  in HUG.restrictHug deps_with_unit hug+++setHUG ::  HomeUnitGraph -> HscEnv -> HscEnv+setHUG deps hsc_env =+  hscUpdateHUG (const $ deps) hsc_env++-- | Wrap an action to catch and handle exceptions.+wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)+wrapAction msg_wrapper hsc_env k = do+  let lcl_logger = hsc_logger hsc_env+      lcl_dynflags = hsc_dflags hsc_env+      print_config = initPrintConfig lcl_dynflags+      logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> srcErrorMessages err)+  -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle+  -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`+  -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to+  -- internally using forkIO.+  mres <- MC.try $ prettyPrintGhcErrors lcl_logger $ k+  case mres of+    Right res -> return $ Just res+    Left exc -> do+        case fromException exc of+          Just (err :: SourceError)+            -> logg err+          Nothing -> case fromException exc of+                        -- ThreadKilled in particular needs to actually kill the thread.+                        -- So rethrow that and the other async exceptions+                        Just (err :: SomeAsyncException) -> throwIO err+                        _ -> errorMsg lcl_logger (text (show exc))+        return Nothing+++++executeInstantiationNode :: Int+  -> Int+  -> HomeUnitGraph+  -> UnitId+  -> InstantiatedUnit+  -> RunMakeM ()+executeInstantiationNode k n deps uid iu = do+        env <- ask+        -- Output of the logger is mediated by a central worker to+        -- avoid output interleaving+        msg <- asks env_messager+        wrapper <- asks diag_wrapper+        lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->+          let lcl_hsc_env = setHUG deps hsc_env+          in wrapAction wrapper lcl_hsc_env $ do+            res <- upsweep_inst lcl_hsc_env msg k n uid iu+            cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)+            return res+++-- | executeCompileNode interprets how --make module should compile a ModuleNode+--+-- 1. If the ModuleNode is a ModuleNodeCompile, then we first check+--    if the interface file exists and is up to date. If it is, we return those.+--    Otherwise, we compile the module and return the new HomeModInfo.+-- 2. If the ModuleNode is a ModuleNodeFixed, then we just need to load the interface+--    and artifacts from disk.++executeCompileNode :: Int+  -> Int+  -> Maybe HomeModInfo+  -> HomeUnitGraph+  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling+  -> ModuleNodeInfo+  -> RunMakeM HomeModInfo+executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do+  me@MakeEnv{..} <- ask+  -- Rehydrate any dependencies if this module had a boot file or is a signature file.+  lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do+     hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mni fixed_mrehydrate_mods+     case mni of+       ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' me  mod+       ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' me key loc+    )++  where+    fixed_mrehydrate_mods =+      case moduleNodeInfoHscSource mni of+        -- MP: It is probably a bit of a misimplementation in backpack that+        -- compiling a signature requires an knot_var for that unit.+        -- If you remove this then a lot of backpack tests fail.+        Just HsigFile -> Just []+        _        -> mrehydrate_mods++    executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo)+    executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod loc =+      wrapAction diag_wrapper hsc_env $ do+        forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc))+        read_result <- readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc)+        case read_result of+          M.Failed interface_err ->+            let mn = mnkModuleName mod+                err = Can'tFindInterface (BadIfaceFile interface_err) (LookingForModule (gwib_mod mn) (gwib_isBoot mn))+            in throwErrors $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (GhcDriverMessage (DriverInterfaceError err))+          M.Succeeded iface -> do+            details <- genModDetails hsc_env iface+            mb_object <- findObjectLinkableMaybe (mi_module iface) loc+            mb_bytecode <- loadIfaceByteCodeLazy hsc_env iface loc (md_types details)+            let hm_linkable = HomeModLinkable mb_bytecode mb_object+            return (HomeModInfo iface details hm_linkable)++    executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo)+    executeCompileNodeWithSource hsc_env MakeEnv{diag_wrapper, env_messager} mod = do+     let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas+         lcl_dynflags = ms_hspp_opts mod+     let lcl_hsc_env =+             -- Localise the hsc_env to use the cached flags+             hscSetFlags lcl_dynflags $+             hsc_env+     -- Compile the module, locking with a semaphore to avoid too many modules+     -- being compiled at the same time leading to high memory usage.+     wrapAction diag_wrapper lcl_hsc_env $ do+      res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n+      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags+      return res+++{- Rehydration, see Note [Rehydrating Modules] -}++rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.+          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.+          -> IO [HomeModInfo]+rehydrate hsc_env hmis = do+  debugTraceMsg logger 2 $ (+     text "Re-hydrating loop: " <+> (ppr (map (mi_module . hm_iface) hmis)))+  -- When the HPT was pure we had to tie a knot to update the ModDetails in the+  -- HPT required to update those ModDetails, but since it was made an IORef we+  -- just have to make sure the new ModDetails are "reset" so that the new+  -- modules are looked up in HPT when it is forced. If we didn't "reset" the+  -- ModDetails, modules in a loop would refer the wrong (hs-boot) definitions+  -- (as explained in Note [Rehydrating Modules]).+  mds <- initIfaceCheck (text "rehydrate") hsc_env $+            mapM (typecheckIface . hm_iface) hmis+  let new_mods = [ hmi{ hm_details = details }+                 | (hmi,details) <- zip hmis mds+                 ]+  return new_mods++  where+    logger = hsc_logger hsc_env++-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the+-- module currently being compiled.+maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv+maybeRehydrateBefore hsc_env _ Nothing = return hsc_env+maybeRehydrateBefore hsc_env mni (Just mns) = do+  knot_var <- initialise_knot_var hsc_env+  let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }+  hmis <- mapM (fmap expectJust . lookupHpt (hsc_HPT hsc_env')) mns+  hmis' <- rehydrate hsc_env' hmis+  mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi (hsc_HUG hsc_env')) hmis'+  return hsc_env'++  where+   initialise_knot_var hsc_env = liftIO $+    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni)+    in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv++rehydrateAfter :: HscEnv+  -> [ModuleName]+  -> IO [HomeModInfo]+rehydrateAfter hsc mns = do+  let hpt = hsc_HPT hsc+  hmis <- mapM (fmap expectJust . lookupHpt hpt) mns+  rehydrate (hsc { hsc_type_env_vars = emptyKnotVars }) hmis++{-+Note [Hydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~+There are at least 4 different representations of an interface file as described+by this diagram.++------------------------------+|       On-disk M.hi         |+------------------------------+    |             ^+    | Read file   | Write file+    V             |+-------------------------------+|      ByteString             |+-------------------------------+    |             ^+    | Binary.get  | Binary.put+    V             |+--------------------------------+|    ModIface (an acyclic AST) |+--------------------------------+    |           ^+    | hydrate   | mkIfaceTc+    V           |+---------------------------------+|  ModDetails (lots of cycles)  |+---------------------------------++The last step, converting a ModIface into a ModDetails is known as "hydration".++Hydration happens in three different places++* When an interface file is initially loaded from disk, it has to be hydrated.+* When a module is finished compiling, we hydrate the ModIface in order to generate+  the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])+* When dealing with boot files and module loops (see Note [Rehydrating Modules])++Note [Rehydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a module has a boot file then it is critical to rehydrate the modules on+the path between the two (see #20561).++Suppose we have ("R" for "recursive"):+```+R.hs-boot:   module R where+               data T+               g :: T -> T++A.hs:        module A( f, T, g ) where+                import {-# SOURCE #-} R+                data S = MkS T+                f :: T -> S = ...g...++R.hs:        module R where+                import A+                data T = T1 | T2 S+                g = ...f...+```++== Why we need to rehydrate A's ModIface before compiling R.hs++After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type+that uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same+AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about+it.)++When compiling R.hs, we build a TyCon for `T`.  But that TyCon mentions `S`, and+it currently has an AbstractTyCon for `T` inside it.  But we want to build a+fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.++Solution: **rehydration**.  *Before compiling `R.hs`*, rehydrate all the+ModIfaces below it that depend on R.hs-boot.  To rehydrate a ModIface, call+`typecheckIface` to convert it to a ModDetails.  It's just a de-serialisation+step, no type inference, just lookups.++Now `S` will be bound to a thunk that, when forced, will "see" the final binding+for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).+But note that this must be done *before* compiling R.hs.++== Why we need to rehydrate A's ModIface after compiling R.hs++When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding+mentions the `LocalId` for `g`.  But when we finish R, we carefully ensure that+all those `LocalIds` are turned into completed `GlobalIds`, replete with+unfoldings etc.   Alas, that will not apply to the occurrences of `g` in `f`'s+unfolding. And if we leave matters like that, they will stay that way, and *all*+subsequent modules that import A will see a crippled unfolding for `f`.++Solution: rehydrate both R and A's ModIface together, right after completing R.hs.++~~ Which modules to rehydrate++We only need rehydrate modules that are+* Below R.hs+* Above R.hs-boot++There might be many unrelated modules (in the home package) that don't need to be+rehydrated.++== Loops with multiple boot files++It is possible for a module graph to have a loop (SCC, when ignoring boot files)+which requires multiple boot files to break. In this case, we must perform+several hydration steps:+  1. The hydration steps described above, which are necessary for correctness.+  2. An extra hydration step at the end of compiling the entire SCC, in order to+     remove space leaks, as we explain below.++Consider the following example:++   ┌─────┐     ┌─────┐+   │  A  │     │  B  │+   └──┬──┘     └──┬──┘+      │           │+  ┌───▼───────────▼───┐+  │         C         │+  └───┬───────────┬───┘+      │           │+ ┌────▼───┐   ┌───▼────┐+ │ A-boot │   │ B-boot │+ └────────┘   └────────┘++A, B and C live together in a SCC. Suppose that we compile the modules in the+order:++  A-boot, B-boot, C, A, B.++When we come to compile A, we will perform the necessary hydration steps,+because A has a boot file. This means that C will be hydrated relative to A,+and the ModDetails for A will reference C/A. Then, when B is compiled,+C will be rehydrated again, and so B will reference C/A,B. At this point,+its interface will be hydrated relative to both A and B.+This causes a space leak: there are now two different copies of C's ModDetails,+kept alive by modules A and B. This is especially problematic if C is large.++The way to avoid this space leak is to rehydrate an entire SCC together at the+end of compilation, so that all the ModDetails point to interfaces for .hs files.+In this example, when we hydrate A, B and C together, then both A and B will refer to+C/A,B.++See #21900 for some more discussion.++== Modules "above" the loop++This dark corner is the subject of #14092.++Suppose we add to our example+```+X.hs     module X where+           import A+           data XT = MkX T+           fx = ...g...+```+If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the argument type of `MkX`.  So:++* Either we should delay compiling X until after R has been compiled. (This is what we do)+* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.++Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.+#20200 has lots of issues, many of them now fixed;+this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).++The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.+Also closely related are+    * #14092+    * #14103++-}++executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()+executeLinkNode hug kn uid deps = do+  withCurrentUnit uid $ do+    MakeEnv{..} <- ask+    let dflags = hsc_dflags hsc_env+    let hsc_env' = setHUG hug hsc_env+        msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager++    linkresult <- liftIO $ withAbstractSem compile_sem $ do+                            link (ghcLink dflags)+                                (hsc_logger hsc_env')+                                (hsc_tmpfs hsc_env')+                                (hsc_FC hsc_env')+                                (hsc_hooks hsc_env')+                                dflags+                                (hsc_unit_env hsc_env')+                                True -- We already decided to link+                                msg'+                                (hsc_HPT hsc_env')+    case linkresult of+      Failed -> fail "Link Failed"+      Succeeded -> return ()++-- | Wait for dependencies to finish, and then return their results.+wait_deps :: [BuildResult] -> RunMakeM [HomeModInfo]+wait_deps [] = return []+wait_deps (x:xs) = do+  res <- lift $ waitResult (resultVar x)+  hmis <- wait_deps xs+  case res of+    Nothing -> return hmis+    Just hmi -> return (hmi:hmis)+++{- Note [GHC Heap Invariants]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~+This note is a general place to explain some of the heap invariants which should+hold for a program compiled with --make mode. These invariants are all things+which can be checked easily using ghc-debug.++1. No HomeModInfo are reachable via the EPS.+   Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains+        a reference to the entire HscEnv, if we are not careful the HscEnv will+        contain the HomePackageTable at the time the interface was loaded and+        it will never be released.+   Where? dontLeakTheHUG in GHC.Iface.Load++2. No KnotVars are live at the end of upsweep (#20491)+   Why? KnotVars contains an old stale reference to the TypeEnv for modules+        which participate in a loop. At the end of a loop all the KnotVars references+        should be removed by the call to typecheckLoop.+   Where? typecheckLoop in GHC.Driver.Make.++3. Immediately after a reload, no ModDetails are live.+   Why? During the upsweep all old ModDetails are replaced with a new ModDetails+        generated from a ModIface. If we don't clear the ModDetails before the+        reload takes place then memory usage during the reload is twice as much+        as it should be as we retain a copy of the ModDetails for too long.+   Where? pruneCache in GHC.Driver.Make++4. No TcGblEnv or TcLclEnv are live after typechecking is completed.+   Why? By the time we get to simplification all the data structures from typechecking+        should be eliminated.+   Where? No one place in the compiler. These leaks can be introduced by not suitable+          forcing functions which take a TcLclEnv as an argument.++5. At the end of a successful upsweep, the number of live ModDetails equals the+   number of non-boot Modules.+   Why? Each module has a HomeModInfo which contains a ModDetails from that module. -}
+ compiler/GHC/Driver/MakeAction.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE CPP #-}+module GHC.Driver.MakeAction+  ( MakeAction(..)+  , MakeEnv(..)+  , RunMakeM+  -- * Running the pipelines+  , runAllPipelines+  , runParPipelines+  , runSeqPipelines+  , runPipelines+  -- * Worker limit+  , WorkerLimit(..)+  , mkWorkerLimit+  , runWorkerLimit+  -- * Utility+  , withLoggerHsc+  , withParLog+  , withLocalTmpFS+  , withLocalTmpFSMake+  ) where++import GHC.Prelude+import GHC.Driver.DynFlags++import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors.Types+import GHC.Driver.Messager+import GHC.Driver.MakeSem++import GHC.Utils.Logger+import GHC.Utils.TmpFs++import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )+import qualified GHC.Conc as CC+import Control.Concurrent.MVar+import Control.Monad+import qualified Control.Monad.Catch as MC++import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )+import Control.Monad.Trans.Reader+import GHC.Driver.Pipeline.LogQueue+import Control.Concurrent.STM+import Control.Monad.Trans.Maybe++-- Executing the pipelines++mkWorkerLimit :: DynFlags -> IO WorkerLimit+mkWorkerLimit dflags =+  case parMakeCount dflags of+    Nothing -> pure $ num_procs 1+    Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h))+    Just ParMakeNumProcessors -> num_procs <$> getNumProcessors+    Just (ParMakeThisMany n) -> pure $ num_procs n+  where+    num_procs x = NumProcessorsLimit (max 1 x)++isWorkerLimitSequential :: WorkerLimit -> Bool+isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1+isWorkerLimitSequential (JSemLimit {})         = False++-- | This describes what we use to limit the number of jobs, either we limit it+-- ourselves to a specific number or we have an external parallelism semaphore+-- limit it for us.+data WorkerLimit+  = NumProcessorsLimit Int+  | JSemLimit+    SemaphoreName+      -- ^ Semaphore name to use+  deriving Eq++-- | Environment used when compiling a module+data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module+                       , compile_sem :: !AbstractSem+                       -- Modify the environment for module k, with the supplied logger modification function.+                       -- For -j1, this wrapper doesn't do anything+                       -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output+                       --          into the log queue.+                       , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a+                       , env_messager :: !(Maybe Messager)+                       , diag_wrapper :: GhcMessage -> AnyGhcDiagnostic+                       }+++label_self :: String -> IO ()+label_self thread_name = do+    self_tid <- CC.myThreadId+    CC.labelThread self_tid thread_name+++runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()+-- Don't even initialise plugins if there are no pipelines+runPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines = do+  liftIO $ label_self "main --make thread"+  case n_job of+    NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env diag_wrapper mHscMessager all_pipelines+    _n -> runParPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines++runSeqPipelines :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()+runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines =+  let env = MakeEnv { hsc_env = plugin_hsc_env+                    , withLogger = \_ k -> k id+                    , compile_sem = AbstractSem (return ()) (return ())+                    , env_messager = mHscMessager+                    , diag_wrapper = diag_wrapper+                    }+  in runAllPipelines (NumProcessorsLimit 1) env all_pipelines++runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a+runNjobsAbstractSem n_jobs action = do+  compile_sem <- newQSem n_jobs+  n_capabilities <- getNumCapabilities+  n_cpus <- getNumProcessors+  let+    asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)+    set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n+    updNumCapabilities =  do+      -- Setting number of capabilities more than+      -- CPU count usually leads to high userspace+      -- lock contention. #9221+      set_num_caps $ min n_jobs n_cpus+    resetNumCapabilities = set_num_caps n_capabilities+  MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem++runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a+#if defined(wasm32_HOST_ARCH)+runWorkerLimit _ action = do+  lock <- newMVar ()+  action $ AbstractSem (takeMVar lock) (putMVar lock ())+#else+runWorkerLimit worker_limit action = case worker_limit of+    NumProcessorsLimit n_jobs ->+      runNjobsAbstractSem n_jobs action+    JSemLimit sem ->+      runJSemAbstractSem sem action+#endif++-- | Build and run a pipeline+runParPipelines :: WorkerLimit -- ^ How to limit work parallelism+             -> HscEnv         -- ^ The basic HscEnv which is augmented with specific info for each module+             -> (GhcMessage -> AnyGhcDiagnostic)+             -> Maybe Messager   -- ^ Optional custom messager to use to report progress+             -> [MakeAction]  -- ^ The build plan for all the module nodes+             -> IO ()+runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipelines = do+++  -- A variable which we write to when an error has happened and we have to tell the+  -- logging thread to gracefully shut down.+  stopped_var <- newTVarIO False+  -- The queue of LogQueues which actions are able to write to. When an action starts it+  -- will add it's LogQueue into this queue.+  log_queue_queue_var <- newTVarIO newLogQueueQueue+  -- Thread which coordinates the printing of logs+  wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var+++  -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.+  thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)+  let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }++  runWorkerLimit worker_limit $ \abstract_sem -> do+    let env = MakeEnv { hsc_env = thread_safe_hsc_env+                      , withLogger = withParLog log_queue_queue_var+                      , compile_sem = abstract_sem+                      , env_messager = mHscMessager+                      , diag_wrapper = diag_wrapper+                      }+    -- Reset the number of capabilities once the upsweep ends.+    runAllPipelines worker_limit env all_pipelines+    atomically $ writeTVar stopped_var True+    wait_log_thread++withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a+withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do+  withLogger k $ \modifyLogger -> do+    let lcl_logger = modifyLogger (hsc_logger hsc_env)+        hsc_env' = hsc_env { hsc_logger = lcl_logger }+    -- Run continuation with modified logger+    cont hsc_env'++withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b+withParLog lqq_var k cont = do+  let init_log = do+        -- Make a new log queue+        lq <- newLogQueue k+        -- Add it into the LogQueueQueue+        atomically $ initLogQueue lqq_var lq+        return lq+      finish_log lq = liftIO (finishLogQueue lq)+  MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))++withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a+withLocalTmpFS tmpfs act = do+  let initialiser = do+        liftIO $ forkTmpFsFrom tmpfs+      finaliser tmpfs_local = do+        liftIO $ mergeTmpFsInto tmpfs_local tmpfs+       -- Add remaining files which weren't cleaned up into local tmp fs for+       -- clean-up later.+       -- Clear the logQueue if this node had it's own log queue+  MC.bracket initialiser finaliser act++withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a+withLocalTmpFSMake env k =+  withLocalTmpFS (hsc_tmpfs (hsc_env env)) $ \lcl_tmpfs+    -> k (env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }})+++-- | Run the given actions and then wait for them all to finish.+runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()+runAllPipelines worker_limit env acts = do+  let single_worker = isWorkerLimitSequential worker_limit+      spawn_actions :: IO [ThreadId]+      spawn_actions = if single_worker+        then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)+        else runLoop forkIOWithUnmask env acts++      kill_actions :: [ThreadId] -> IO ()+      kill_actions tids = mapM_ killThread tids++  MC.bracket spawn_actions kill_actions $ \_ -> do+    mapM_ waitMakeAction acts++-- | Execute each action in order, limiting the amount of parallelism by the given+-- semaphore.+runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]+runLoop _ _env [] = return []+runLoop fork_thread env (MakeAction act res_var :acts) = do++  -- withLocalTmpFs has to occur outside of fork to remain deterministic+  new_thread <- withLocalTmpFSMake env $ \lcl_env ->+    fork_thread $ \unmask -> (do+            mres <- (unmask $ run_pipeline lcl_env act)+                      `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.+            putMVar res_var mres)+  threads <- runLoop fork_thread env acts+  return (new_thread : threads)+  where+      run_pipeline :: MakeEnv -> RunMakeM a -> IO (Maybe a)+      run_pipeline env p = runMaybeT (runReaderT p env)++type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a++data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))++waitMakeAction :: MakeAction -> IO ()+waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
+ compiler/GHC/Driver/Messager.hs view
@@ -0,0 +1,66 @@+module GHC.Driver.Messager (Messager, oneShotMsg, batchMsg, batchMultiMsg, showModuleIndex) where++import GHC.Prelude+import GHC.Driver.Env+import GHC.Unit.Module.Graph+import GHC.Iface.Recomp+import GHC.Utils.Logger+import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Unit.State++type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()++--------------------------------------------------------------+-- Progress displayers.+--------------------------------------------------------------++oneShotMsg :: Logger -> RecompileRequired -> IO ()+oneShotMsg logger recomp =+    case recomp of+        UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"+        NeedsRecompile _ -> return ()++batchMsg :: Messager+batchMsg = batchMsgWith (\_ _ _ _ -> empty)+batchMultiMsg :: Messager+batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (mgNodeUnitId node)))++batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager+batchMsgWith extra hsc_env_start mod_index recomp node =+      case recomp of+        UpToDate+          | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty+          | otherwise -> return ()+        NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of+          MustCompile            -> empty+          (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"+    where+        herald = case node of+                    LinkNode {} -> "Linking"+                    InstantiationNode {} -> "Instantiating"+                    ModuleNode {} -> "Compiling"+                    UnitNode {} -> "Loading"+        hsc_env = hscSetActiveUnitId (mgNodeUnitId node) hsc_env_start+        dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+        state  = hsc_units hsc_env+        showMsg msg reason =+            compilationProgressMsg logger $+            (showModuleIndex mod_index <>+            msg <+> showModMsg dflags (recompileRequired recomp) node)+                <> extra hsc_env mod_index recomp node+                <> reason++{- **********************************************************************+%*                                                                      *+        Progress Messages: Module i of n+%*                                                                      *+%********************************************************************* -}++showModuleIndex :: (Int, Int) -> SDoc+showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "+  where+    -- compute the length of x > 0 in base 10+    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)+    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr
compiler/GHC/Driver/Pipeline.hs view
@@ -44,6 +44,7 @@   import GHC.Prelude+import GHC.Builtin.Names  import GHC.Platform @@ -91,6 +92,7 @@ import GHC.Data.Maybe          ( expectJust )  import GHC.Iface.Make          ( mkFullIface )+import GHC.Iface.Load          ( getGhcPrimIface ) import GHC.Runtime.Loader      ( initializePlugins )  @@ -105,11 +107,10 @@ import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder---import GHC.Unit.State import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable  import System.Directory import System.FilePath@@ -253,7 +254,7 @@   where lcl_dflags  = ms_hspp_opts summary        location    = ms_location summary-       input_fn    = expectJust "compile:hs" (ml_hs_file location)+       input_fn    = expectJust (ml_hs_file location)        input_fnpp  = ms_hspp_file summary         pipelineOutput = backendPipelineOutput bcknd@@ -403,18 +404,18 @@                           LinkStaticLib -> True                           _ -> False -            home_mod_infos = eltsHpt hpt+        -- the packages we depend on+        -- TODO: This should be a query on the 'ModuleGraph', since we need to+        -- know which packages are actually needed at the runtime stage.+        pkg_deps <- map snd . Set.toList <$> hptCollectDependencies hpt -            -- the packages we depend on-            pkg_deps  = Set.toList-                          $ Set.unions-                          $ fmap (dep_direct_pkgs . mi_deps . hm_iface)-                          $ home_mod_infos+        -- the linkables to link+        linkables <- hptCollectObjects hpt -            -- the linkables to link-            linkables = map (expectJust "link". homeModInfoObject) home_mod_infos+        -- the home modules, for tracing+        home_modules <- hptCollectModules hpt -        debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map (ppr . mi_module . hm_iface) home_mod_infos))+        debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map ppr home_modules))         debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))         debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps)) @@ -472,7 +473,7 @@         -- modification times on all of the objects and libraries, then omit         -- linking (unless the -fforce-recomp flag was given).   let platform   = ue_platform unit_env-      unit_state = ue_units unit_env+      unit_state = ue_homeUnitState unit_env       arch_os    = platformArchOS platform       exe_file   = exeFileName arch_os staticLink (outputFile_ dflags)   e_exe_time <- tryIO $ getModificationUTCTime exe_file@@ -820,7 +821,13 @@         let !linkable = Linkable part_time (ms_mod mod_sum) (NE.singleton (DotO final_object ModuleObject))         -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.         return (mlinkable { homeMod_object = Just linkable })-  return (miface, final_linkable)++  -- when building ghc-internal with --make (e.g. with cabal-install), we want+  -- the virtual interface for gHC_PRIM in the cache, not the empty one.+  let miface_final+        | ms_mod mod_sum == gHC_PRIM = getGhcPrimIface (hsc_hooks hsc_env)+        | otherwise                  = miface+  return (miface_final, final_linkable)  asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile) asPipeline use_cpp pipe_env hsc_env location input_fn =
compiler/GHC/Driver/Pipeline.hs-boot view
@@ -3,12 +3,22 @@  import GHC.Driver.Env.Types ( HscEnv ) import GHC.ForeignSrcLang ( ForeignSrcLang )-import GHC.Prelude (FilePath, IO)+import GHC.Prelude (FilePath, IO, Maybe, Either) import GHC.Unit.Module.Location (ModLocation) import GHC.Driver.Session (DynFlags)+import GHC.Driver.Phases (Phase)+import GHC.Driver.Errors.Types (DriverMessages)+import GHC.Types.Target (InputFileBuffer)  import Language.Haskell.Syntax.Module.Name  -- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()++preprocess :: HscEnv+           -> FilePath+           -> Maybe InputFileBuffer+           -> Maybe Phase+           -> IO (Either DriverMessages (DynFlags, FilePath))+
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} #include <ghcplatform.h>  {- Functions for providing the default interpretation of the 'TPhase' actions@@ -34,6 +33,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Types.SrcLoc import GHC.Driver.Main+import GHC.Driver.Downsweep import GHC.Tc.Types import GHC.Types.Error import GHC.Driver.Errors.Types@@ -478,7 +478,7 @@           -- very weakly typed, being derived from C--.           ["-fno-strict-aliasing"] -  ghcVersionH <- getGhcVersionPathName dflags unit_env+  ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env    withAtomicRename output_fn $ \temp_outputFilename ->     GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (@@ -512,7 +512,7 @@                         Just hu                           | isHomeUnitId hu ghcInternalUnitId                           , platformOS platform == OSMinGW32-                          -> ["-DCOMPILING_BASE_PACKAGE"]+                          -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"]                         _ -> [])                   -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.@@ -525,7 +525,7 @@                        else [])                  ++ verbFlags                  ++ cc_opt-                 ++ [ "-include", ghcVersionH ]+                 ++ ghcVersionH                  ++ framework_paths                  ++ include_paths                  ++ pkg_extra_cc_opts@@ -560,7 +560,7 @@                    HsigFile -> do                      -- We need to create a REAL but empty .o file                      -- because we are going to attempt to put it in a library-                     let input_fn = expectJust "runPhase" (ml_hs_file location)+                     let input_fn = expectJust (ml_hs_file location)                          basename = dropExtension input_fn                      compileEmptyStub dflags hsc_env basename location mod_name @@ -658,10 +658,11 @@ getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages DriverMessage)) getFileArgs hsc_env input_fn = do   let dflags0 = hsc_dflags hsc_env+      logger  = hsc_logger hsc_env       parser_opts = initParserOpts dflags0-  (warns0, src_opts) <- getOptionsFromFile parser_opts input_fn+  (warns0, src_opts) <- getOptionsFromFile parser_opts (supportedLanguagePragmas dflags0) input_fn   (dflags1, unhandled_flags, warns)-    <- parseDynamicFilePragma dflags0 src_opts+    <- parseDynamicFilePragma logger dflags0 src_opts   checkProcessArgsResult unhandled_flags   return (dflags1, warns0, warns) @@ -703,17 +704,17 @@   hsc_env <- initializePlugins hsc_env1    -- gather the imports and module name-  (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do+  (hspp_buf,mod_name,imps,src_imps) <- do     buf <- hGetStringBuffer input_fn     let imp_prelude = xopt LangExt.ImplicitPrelude dflags         popts = initParserOpts dflags         rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)-        rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))+        rn_imps = fmap (\(s, rpk, lmn@(L _ mn)) -> (s, rn_pkg_qual mn rpk, lmn))     eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)     case eimps of         Left errs -> throwErrors (GhcPsMessage <$> errs)-        Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return-              (Just buf, mod_name, rn_imps imps, rn_imps src_imps, ghc_prim_imp)+        Right (src_imps,imps, L _ mod_name) -> return+              (Just buf, mod_name, rn_imps imps, src_imps)    -- Take -o into account if present   -- Very like -ohi, but we must *only* do this if we aren't linking@@ -736,7 +737,7 @@   mod <- do     let home_unit = hsc_home_unit hsc_env     let fc        = hsc_FC hsc_env-    addHomeModuleToFinder fc home_unit (GWIB mod_name (hscSourceToIsBoot src_flavour)) location+    addHomeModuleToFinder fc home_unit mod_name location src_flavour    -- Make the ModSummary to hand to hscMain   let@@ -752,7 +753,6 @@                                 ms_parsed_mod   = Nothing,                                 ms_iface_date   = hi_date,                                 ms_hie_date     = hie_date,-                                ms_ghc_prim_import = ghc_prim_imp,                                 ms_textual_imps = imps,                                 ms_srcimps      = src_imps } @@ -761,12 +761,19 @@   let msg :: Messager       msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what +  -- A lazy module graph thunk, don't force it unless you need it!+  mg <- downsweepThunk hsc_env mod_summary+   -- 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 <- newIORef emptyNameEnv-  let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }+  let hsc_env' =+        setModuleGraph mg+          hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } ++   status <- hscRecompStatus (Just msg) hsc_env' mod_summary                         Nothing emptyHomeModInfoLinkable (1, 1) @@ -779,24 +786,18 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do     let PipeEnv{ src_basename=basename,              src_suffix=suff } = pipe_env-    let location1 = mkHomeModLocation2 fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff)--    -- Boot-ify it if necessary-    let location2-          | HsBootFile <- src_flavour = addBootSuffixLocnOut location1-          | otherwise                 = location1-+    let location1 = mkHomeModLocation fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff) src_flavour      -- 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_ospath = unsafeEncodeUtf  fn }-                  | otherwise      = location2+        location2 | Just fn <- ohi = location1{ ml_hi_file_ospath = unsafeEncodeUtf fn }+                  | otherwise      = location1      let dynohi = dynOutputHi dflags-        location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }-                  | otherwise         = location3+        location3 | Just fn <- dynohi = location2{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }+                  | otherwise         = location2      -- Take -o into account if present     -- Very like -ohi, but we must *only* do this if we aren't linking@@ -809,11 +810,11 @@         location5 | Just ofile <- expl_o_file                   , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file                   , isNoLink (ghcLink dflags)-                  = location4 { ml_obj_file_ospath = unsafeEncodeUtf ofile+                  = location3 { ml_obj_file_ospath = unsafeEncodeUtf ofile                               , ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }                   | Just dyn_ofile <- expl_dyn_o_file-                  = location4 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }-                  | otherwise = location4+                  = location3 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }+                  | otherwise = location3     return location5     where       fopts = initFinderOpts dflags@@ -972,7 +973,7 @@    where target = platformMisc_llvmTarget $ platformMisc dflags         target_os = platformOS (targetPlatform dflags)-        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets llvm_config)+        LlvmTarget _ mcpu mattr = expectJust $ lookup target (llvmTargets llvm_config)          -- Relocation models         rmodel |  gopt Opt_PIC dflags@@ -994,6 +995,9 @@                    -- LLVM gates POPCNT instructions behind the popcnt flag,                    -- while the GHC NCG (as well as GCC, Clang) gates it                    -- behind SSE4.2 instead.+              ++ ["+sse4.1"  | isSse4_1Enabled dflags   ]+              ++ ["+ssse3"   | isSsse3Enabled dflags    ]+              ++ ["+sse3"    | isSse3Enabled dflags     ]               ++ ["+sse2"    | isSse2Enabled platform   ]               ++ ["+sse"     | isSseEnabled platform    ]               ++ ["+avx512f" | isAvx512fEnabled dflags  ]
+ compiler/GHC/Driver/Session/Inspect.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE LambdaCase #-}++-- | GHC API utilities for inspecting the GHC session+module GHC.Driver.Session.Inspect where++import GHC.Prelude+import GHC.Data.Maybe+import Control.Monad++import GHC.ByteCode.Types+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv+import GHC.Driver.Env+import GHC.Driver.Main+import GHC.Driver.Monad+import GHC.Driver.Session+import GHC.Rename.Names+import GHC.Runtime.Context+import GHC.Runtime.Interpreter+import GHC.Types.Avail+import GHC.Types.Name+import GHC.Types.Name.Ppr+import GHC.Types.Name.Reader+import GHC.Types.Name.Set+import GHC.Types.PkgQual+import GHC.Types.SafeHaskell+import GHC.Types.SrcLoc+import GHC.Types.TyThing+import GHC.Types.TypeEnv+import GHC.Unit.External+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module+import GHC.Unit.Module.Graph+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Utils.Misc+import GHC.Utils.Outputable+import qualified GHC.Unit.Home.Graph as HUG++-- %************************************************************************+-- %*                                                                      *+--             Inspecting the session+-- %*                                                                      *+-- %************************************************************************++-- | Get the module dependency graph.+getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary+getModuleGraph = liftM hsc_mod_graph getSession++{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-}+-- | Return @True@ \<==> module is loaded.+isLoaded :: GhcMonad m => ModuleName -> m Bool+isLoaded m = withSession $ \hsc_env -> liftIO $ do+  hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m+  return $! not (null hmis)++-- | Check whether a 'ModuleName' is found in the 'HomePackageTable'+-- for the given 'UnitId'.+isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool+isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do+  hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m+  return $! isJust hmi++-- | Check whether 'Module' is part of the 'HomeUnitGraph'.+--+-- Similar to 'isLoadedModule', but for 'Module's.+isLoadedHomeModule :: GhcMonad m => Module -> m Bool+isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do+  hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env)+  return $! isJust hmi++-- | Return the bindings for the current interactive session.+getBindings :: GhcMonad m => m [TyThing]+getBindings = withSession $ \hsc_env ->+    return $ icInScopeTTs $ hsc_IC hsc_env++-- | Return the instances for the current interactive session.+getInsts :: GhcMonad m => m ([ClsInst], [FamInst])+getInsts = withSession $ \hsc_env ->+    let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)+    in return (instEnvElts inst_env, fam_env)++getNamePprCtx :: GhcMonad m => m NamePprCtx+getNamePprCtx = withSession $ \hsc_env -> do+  return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)++-- | Container for information about a 'Module'.+data ModuleInfo = ModuleInfo {+        minf_type_env  :: TypeEnv,+        minf_exports   :: [AvailInfo],+        minf_instances :: [ClsInst],+        minf_iface     :: Maybe ModIface,+        minf_safe      :: SafeHaskellMode,+        minf_modBreaks :: Maybe InternalModBreaks+  }+        -- We don't want HomeModInfo here, because a ModuleInfo applies+        -- to package modules too.++-- | Request information about a loaded 'Module'+getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X+getModuleInfo mdl = withSession $ \hsc_env -> do+  if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env)+        then liftIO $ getHomeModuleInfo hsc_env mdl+        else liftIO $ getPackageModuleInfo hsc_env mdl++getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)+getPackageModuleInfo hsc_env mdl+  = do  eps <- hscEPS hsc_env+        iface <- hscGetModuleInterface hsc_env mdl+        let+            avails = mi_exports iface+            pte    = eps_PTE eps+            tys    = [ ty | name <- concatMap availNames avails,+                            Just ty <- [lookupTypeEnv pte name] ]++        return (Just (ModuleInfo {+                        minf_type_env  = mkTypeEnv tys,+                        minf_exports   = avails,+                        minf_instances = error "getModuleInfo: instances for package module unimplemented",+                        minf_iface     = Just iface,+                        minf_safe      = getSafeMode $ mi_trust iface,+                        minf_modBreaks = Nothing+                }))++availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv+availsToGlobalRdrEnv hsc_env mod avails+  = forceGlobalRdrEnv rdr_env+    -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.+  where+    rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails)+      -- We're building a GlobalRdrEnv as if the user imported+      -- all the specified modules into the global interactive module+    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}+    decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod,+                         is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual,+                         is_dloc = srcLocSpan interactiveSrcLoc,+                         is_level = NormalLevel }++getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)+getHomeModuleInfo hsc_env mdl =+  HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case+    Nothing  -> return Nothing+    Just hmi -> do+      let details  = hm_details hmi+          iface    = hm_iface hmi+      return (Just (ModuleInfo {+                        minf_type_env  = md_types details,+                        minf_exports   = md_exports details,+                         -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo.+                        minf_instances = instEnvElts $ md_insts details,+                        minf_iface     = Just iface,+                        minf_safe      = getSafeMode $ mi_trust iface,+                        minf_modBreaks = getModBreaks hmi+                        }))++-- | The list of top-level entities defined in a module+modInfoTyThings :: ModuleInfo -> [TyThing]+modInfoTyThings minf = typeEnvElts (minf_type_env minf)++modInfoExports :: ModuleInfo -> [Name]+modInfoExports minf = concatMap availNames $! minf_exports minf++modInfoExportsWithSelectors :: ModuleInfo -> [Name]+modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf++-- | Returns the instances defined by the specified module.+-- Warning: currently unimplemented for package modules.+modInfoInstances :: ModuleInfo -> [ClsInst]+modInfoInstances = minf_instances++modInfoIsExportedName :: ModuleInfo -> Name -> Bool+modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))++mkNamePprCtxForModule ::+  GhcMonad m =>+  Module     ->+  ModuleInfo ->+  m NamePprCtx+mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do+  let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))+      ptc = initPromotionTickContext (hsc_dflags hsc_env)+  return name_ppr_ctx++modInfoLookupName :: GhcMonad m =>+                     ModuleInfo -> Name+                  -> m (Maybe TyThing) -- XXX: returns a Maybe X+modInfoLookupName minf name = withSession $ \hsc_env -> do+   case lookupTypeEnv (minf_type_env minf) name of+     Just tyThing -> return (Just tyThing)+     Nothing      -> liftIO (lookupType hsc_env name)++modInfoIface :: ModuleInfo -> Maybe ModIface+modInfoIface = minf_iface++-- | Retrieve module safe haskell mode+modInfoSafe :: ModuleInfo -> SafeHaskellMode+modInfoSafe = minf_safe++modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks+modInfoModBreaks = minf_modBreaks+
compiler/GHC/Hs/Stats.hs view
@@ -115,6 +115,7 @@     sig_info (FixSig {})     = (1,0,0,0,0)     sig_info (TypeSig {})    = (0,1,0,0,0)     sig_info (SpecSig {})    = (0,0,1,0,0)+    sig_info (SpecSigE {})   = (0,0,1,0,0)     sig_info (InlineSig {})  = (0,0,0,1,0)     sig_info (ClassOpSig {}) = (0,0,0,0,1)     sig_info _               = (0,0,0,0,0)@@ -134,9 +135,8 @@     spec_info (Just (Exactly, _)) = (0,0,0,0,0,1,0)     spec_info (Just (EverythingBut, _))  = (0,0,0,0,0,0,1) -    data_info (DataDecl { tcdDataDefn = HsDataDefn-                                          { dd_cons = cs-                                          , dd_derivs = derivs}})+    data_info (DataDecl { tcdDataDefn = dd :: HsDataDefn GhcPs })+        | HsDataDefn { dd_cons = cs, dd_derivs = derivs} <- dd         = ( length cs           , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)                    0 derivs )
compiler/GHC/Hs/Syn/Type.hs view
@@ -7,8 +7,7 @@     -- * Extracting types from HsExpr     lhsExprType, hsExprType, hsWrapperType,     -- * Extracting types from HsSyn-    hsLitType, hsPatType, hsLPatType-+    hsLitType, hsPatType, hsLPatType,   ) where  import GHC.Prelude@@ -72,7 +71,7 @@     ExpansionPat _ pat -> hsPatType pat hsPatType (SplicePat v _)               = dataConCantHappen v -hsLitType :: HsLit (GhcPass p) -> Type+hsLitType :: forall p. IsPass p => HsLit (GhcPass p) -> Type hsLitType (HsChar _ _)       = charTy hsLitType (HsCharPrim _ _)   = charPrimTy hsLitType (HsString _ _)     = stringTy@@ -89,10 +88,12 @@ hsLitType (HsWord16Prim _ _) = word16PrimTy hsLitType (HsWord32Prim _ _) = word32PrimTy hsLitType (HsWord64Prim _ _) = word64PrimTy-hsLitType (HsInteger _ _ ty) = ty-hsLitType (HsRat _ _ ty)     = ty hsLitType (HsFloatPrim _ _)  = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy+hsLitType (XLit x)           = case ghcPass @p of+      GhcTc -> case x of+         (HsInteger _ _ ty) -> ty+         (HsRat  _ ty)      -> ty   -- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion.@@ -102,7 +103,6 @@ -- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion. hsExprType :: HsExpr GhcTc -> Type hsExprType (HsVar _ (L _ id)) = idType id-hsExprType (HsUnboundVar (HER _ ty _) _) = ty hsExprType (HsOverLabel v _) = dataConCantHappen v hsExprType (HsIPVar v _) = dataConCantHappen v hsExprType (HsOverLit _ lit) = overLitType lit@@ -145,6 +145,7 @@ hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e hsExprType (HsEmbTy x _) = dataConCantHappen x+hsExprType (HsHole (_, (HER _ ty _))) = ty hsExprType (HsQual x _ _) = dataConCantHappen x hsExprType (HsForAll x _ _) = dataConCantHappen x hsExprType (HsFunArr x _ _ _) = dataConCantHappen x@@ -200,7 +201,6 @@     go (WpTyLam tv)       = liftPRType $ mkForAllTy (Bndr tv Inferred)     go (WpTyApp ta)       = \(ty,tas) -> (ty, ta:tas)     go (WpLet _)          = id-    go (WpMultCoercion _) = id  lhsCmdTopType :: LHsCmdTop GhcTc -> Type lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty
compiler/GHC/HsToCore.hs view
@@ -22,14 +22,12 @@ import GHC.Driver.Config import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO ) import GHC.Driver.Config.HsToCore.Ticks-import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Plugins  import GHC.Hs -import GHC.HsToCore.Usage import GHC.HsToCore.Monad import GHC.HsToCore.Errors.Types import GHC.HsToCore.Expr@@ -41,8 +39,8 @@ import GHC.HsToCore.Docs  import GHC.Tc.Types-import GHC.Tc.Types.Origin ( Position(..) )-import GHC.Tc.Utils.Monad  ( finalSafeMode, fixSafeInstances, initIfaceLoad )+import GHC.Tc.Types.Origin ( Position(..), mkArgPos )+import GHC.Tc.Utils.Monad  ( finalSafeMode, fixSafeInstances ) import GHC.Tc.Module ( runTcInteractive )  import GHC.Core.Type@@ -54,6 +52,7 @@ import GHC.Core.Utils import GHC.Core.Unfold.Make import GHC.Core.Coercion+import GHC.Core.Predicate( scopedSort, mkNomEqPred ) import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make import GHC.Core.Rules@@ -70,7 +69,7 @@  import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Panic.Plain+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Logger@@ -98,7 +97,8 @@  import Data.List (partition) import Data.IORef-import Data.Traversable (for)+import GHC.Iface.Make (mkRecompUsageInfo)+import GHC.Runtime.Interpreter (interpreterProfiled)  {- ************************************************************************@@ -121,17 +121,14 @@                             tcg_imports      = imports,                             tcg_exports      = exports,                             tcg_keep         = keep_var,-                            tcg_th_splice_used = tc_splice_used,                             tcg_rdr_env      = rdr_env,                             tcg_fix_env      = fix_env,                             tcg_inst_env     = inst_env,                             tcg_fam_inst_env = fam_inst_env,-                            tcg_merged       = merged,                             tcg_warns        = warns,                             tcg_anns         = anns,                             tcg_binds        = binds,                             tcg_imp_specs    = imp_specs,-                            tcg_dependent_files = dependent_files,                             tcg_ev_binds     = ev_binds,                             tcg_th_foreign_files = th_foreign_files_var,                             tcg_fords        = fords,@@ -141,7 +138,6 @@                             tcg_default_exports = defaults,                             tcg_insts        = insts,                             tcg_fam_insts    = fam_insts,-                            tcg_hpc          = other_hpc_info,                             tcg_complete_matches = complete_matches,                             tcg_self_boot    = self_boot                             })@@ -166,13 +162,12 @@                                        mod mod_loc                                        export_set (typeEnvTyCons type_env) binds                               else return (binds, Nothing)-        ; modBreaks <- for-           [ (i, s)-           | i <- hsc_interp hsc_env-           , (_, s) <- m_tickInfo-           , breakpointsAllowed dflags-           ]-           $ \(interp, specs) -> mkModBreaks interp mod specs+        ; let modBreaks+                | Just (_, specs) <- m_tickInfo+                , breakpointsAllowed dflags+                = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs+                | otherwise+                = Nothing          ; ds_hpc_info <- case m_tickInfo of             Just (orig_file2, ticks)@@ -182,7 +177,7 @@                 then writeMixEntries (hpcDir dflags) mod ticks orig_file2                 else return 0 -- dummy hash when none are written               pure $ HpcInfo (fromIntegral $ sizeSS ticks) hashNo-            _ -> pure $ emptyHpcInfo other_hpc_info+            _ -> pure $ emptyHpcInfo          ; (msgs, mb_res) <- initDs hsc_env tcg_env $                        do { dsEvBinds ev_binds $ \ ds_ev_binds -> do@@ -227,26 +222,17 @@          ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugarOpt ds_binds ds_rules_for_imps -        ; let used_names = mkUsedNames tcg_env-              pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))+        ; let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))               home_unit = hsc_home_unit hsc_env         ; let deps = mkDependencies home_unit                                     (tcg_mod tcg_env)                                     (tcg_imports tcg_env)                                     (map mi_module pluginModules) -        ; used_th <- readIORef tc_splice_used-        ; dep_files <- readIORef dependent_files         ; safe_mode <- finalSafeMode dflags tcg_env-        ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env) -        ; let uc = initUsageConfig hsc_env-        ; let plugins = hsc_plugins hsc_env-        ; let fc = hsc_FC hsc_env-        ; let unit_env = hsc_unit_env hsc_env-        ; usages <- initIfaceLoad hsc_env $-                      mkUsageInfo uc plugins fc unit_env mod (imp_mods imports) used_names-                        dep_files merged needed_mods needed_pkgs+        ; usages <- mkRecompUsageInfo hsc_env tcg_env+         -- id_mod /= mod when we are processing an hsig, but hsigs         -- never desugared and compiled (there's no code!)         -- Consequently, this should hold for any ModGuts that make@@ -264,7 +250,6 @@                 mg_exports      = exports,                 mg_usages       = usages,                 mg_deps         = deps,-                mg_used_th      = used_th,                 mg_rdr_env      = rdr_env,                 mg_fix_env      = fix_env,                 mg_warns        = warns,@@ -291,12 +276,6 @@         ; return (msgs, Just mod_guts)         }}}} -dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])-dsImpSpecs imp_specs- = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs-      ; let (spec_binds, spec_rules) = unzip spec_prs-      ; return (concatOL spec_binds, spec_rules) }- combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] -- Top-level bindings can include coercion bindings, but not via superclasses -- See Note [Top-level evidence]@@ -335,7 +314,7 @@        -- 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-    let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result+    let (ds_msgs, mb_core_expr) = expectJust mb_result      case mb_core_expr of        Nothing   -> return ()@@ -441,14 +420,18 @@ dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) dsRule (L loc (HsRule { rd_name = name                       , rd_act  = rule_act-                      , rd_tmvs = vars+                      , rd_bndrs = RuleBndrs { rb_ext = bndrs }                       , rd_lhs  = lhs                       , rd_rhs  = rhs }))   = putSrcSpanDs (locA loc) $-    do  { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]+    do  { let bndrs' = scopedSort bndrs+                 -- The scopedSort is because the binders may not+                 -- be in dependency order; see wrinkle (FTV1) in+                 -- Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type          ; lhs' <- unsetGOptM Opt_EnableRewriteRules $-                  unsetWOptM Opt_WarnIdentities $+                  unsetWOptM Opt_WarnIdentities     $+                  zapUnspecables                    $                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]          ; rhs' <- dsLExpr rhs@@ -549,6 +532,9 @@ the rule is precisely to optimise them:   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} +Finally, the `zapUnspecables` is to implement (NC1) of+Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr+ Note [Desugaring coerce as cast] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want the user to express a rule saying roughly “mapping a coercion over a@@ -762,7 +748,7 @@              unsafe_equality k a b                = ( mkTyApps (Var unsafe_equality_proof_id) [k,b,a]                  , mkTyConApp unsafe_equality_tc [k,b,a]-                 , mkNomPrimEqPred k a b+                 , mkNomEqPred a b                  )              -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to              -- carefully swap the arguments above@@ -794,7 +780,7 @@              arity = 1               concs = mkRepPolyIdConcreteTyVars-                     [((mkTyVarTy openAlphaTyVar, Argument 1 Top), runtimeRep1TyVar)]+                     [((mkTyVarTy openAlphaTyVar, mkArgPos 1 Top), runtimeRep1TyVar)]                      unsafeCoercePrimName               id   = mkExportedLocalId (RepPolyId concs) unsafeCoercePrimName ty `setIdInfo` info
compiler/GHC/HsToCore/Arrows.hs view
@@ -530,7 +530,7 @@ dsCmd ids local_vars stack_ty res_ty         (HsCmdLam _ LamSingle (MG { mg_alts           = (L _ [L _ (Match { m_pats  = L _ pats-                             , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))+                             , m_grhss = GRHSs _ (L _ (GRHS _ [] body) :| _) _ })]) }))         env_ids   = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids @@ -1215,7 +1215,7 @@     [(body,       mkVarSet (collectLStmtsBinders CollWithDictBinders stmts)         `unionVarSet` defined_vars)-    | L _ (GRHS _ stmts body) <- grhss]+    | L _ (GRHS _ stmts body) <- toList grhss]  -- Replace the leaf commands in a match 
compiler/GHC/HsToCore/Binds.hs view
@@ -1,5 +1,6 @@  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-}  {-@@ -15,7 +16,8 @@ -}  module GHC.HsToCore.Binds-   ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec+   ( dsTopLHsBinds, dsLHsBinds+   , dsImpSpecs, decomposeRuleLhs    , dsHsWrapper, dsHsWrappers    , dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds    , dsWarnOrphanRule@@ -42,7 +44,7 @@  import GHC.Hs             -- lots of things import GHC.Core           -- lots of things-import GHC.Core.SimpleOpt    ( simpleOptExpr )+import GHC.Core.SimpleOpt import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.InstEnv ( CanonicalEvidence(..) ) import GHC.Core.Make@@ -55,6 +57,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Rules+import GHC.Core.Ppr( pprCoreBinders ) import GHC.Core.TyCo.Compare( eqType )  import GHC.Builtin.Names@@ -63,11 +66,11 @@ import GHC.Tc.Types.Evidence  import GHC.Types.Id-import GHC.Types.Id.Make ( nospecId )+import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Types.Var( EvVar )+import GHC.Types.Var( EvVar, mkLocalVar ) import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Unique.Set( nonDetEltsUniqSet )@@ -76,7 +79,6 @@ import GHC.Data.OrdList import GHC.Data.Graph.Directed import GHC.Data.Bag-import qualified Data.Set as S  import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc@@ -86,6 +88,7 @@  import Control.Monad + {-********************************************************************** *                                                                      *            Desugaring a MonoBinds@@ -204,33 +207,25 @@                            , fun_matches = matches                            , fun_ext = (co_fn, tick)                            })- = do   { dsHsWrapper co_fn $ \core_wrap -> do-        { (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $-                          -- FromSource might not be accurate (we don't have any-                          -- origin annotations for things in this module), but at-                          -- worst we do superfluous calls to the pattern match-                          -- oracle.-                          -- addTyCs: Add type evidence to the refinement type-                          --            predicate of the coverage checker-                          -- See Note [Long-distance information] in "GHC.HsToCore.Pmc"-                          matchWrapper (mkPrefixFunRhs (L loc (idName fun)) noAnn) Nothing matches+ = dsHsWrapper co_fn $ \core_wrap ->+   do { (args, body) <- matchWrapper (mkPrefixFunRhs (L loc (idName fun)) noAnn) Nothing matches -        ; let body' = mkOptTickBox tick body-              rhs   = core_wrap (mkLams args body')-              core_binds@(id,_) = makeCorePair dflags fun False 0 rhs-              force_var-                  -- Bindings are strict when -XStrict is enabled-                | xopt LangExt.Strict dflags-                , matchGroupArity matches == 0 -- no need to force lambdas-                = [id]-                | isBangedHsBind b-                = [id]-                | otherwise-                = []-        ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)-          --                          , ppr (mg_alts matches)-          --                          , ppr args, ppr core_binds, ppr body']) $-          return (force_var, [core_binds]) } }+      ; let body' = mkOptTickBox tick body+            rhs   = core_wrap (mkLams args body')+            core_binds@(id,_) = makeCorePair dflags fun False 0 rhs+            force_var+                -- Bindings are strict when -XStrict is enabled+              | xopt LangExt.Strict dflags+              , matchGroupArity matches == 0 -- no need to force lambdas+              = [id]+              | isBangedHsBind b+              = [id]+              | otherwise+              = []+      ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)+        --                          , ppr (mg_alts matches)+        --                          , ppr args, ppr core_binds, ppr body']) $+        return (force_var, [core_binds]) }  dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss                          , pat_ext = (ty, (rhs_tick, var_ticks))@@ -253,15 +248,15 @@                         , abs_exports = exports                         , abs_ev_binds = ev_binds                         , abs_binds = binds, abs_sig = has_sig }))-  = dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do-    { ds_binds <- addTyCs FromSource (listToBag dicts) $-                     dsLHsBinds binds+  = addTyCs FromSource (listToBag dicts) $              -- addTyCs: push type constraints deeper              --            for inner pattern match check              -- See Check, Note [Long-distance information]--    -- dsAbsBinds does the hard work-    ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds (isSingleton binds) has_sig }+    dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do+    do { ds_binds <- dsLHsBinds binds+         -- dsAbsBinds does the hard work+       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds+                    (isSingleton binds) has_sig }  dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" @@ -795,6 +790,122 @@    4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. +Note [Desugaring new-form SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+"New-form" SPECIALISE pragmas generate a SpecPragE record in the typechecker,+which is desugared in this module by `dsSpec`.  For the context see+Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig++Suppose we have+  f :: forall a b c d. (Ord a, Ord b, Eq c, Ix d) => ...+  f = rhs+  {-# SPECIALISE f @p @[p] @[Int] @(q,r) #-}++The type-checker generates `the_call` which looks like++  spe_bndrs = (dx1 :: Ord p) (dx2::Ix q) (dx3::Ix r)+  the_call = let d6 = dx1+                 d2 = $fOrdList d6+                 d3 = $fEqList $fEqInt+                 d7 = dx1   -- Solver may introduce+                 d1 = d7    -- these indirections+                 d4 = $fIxPair dx2 dx3+             in f @p @p @[Int] @(q,r)+                  (d1::Ord p) (d2::Ord [p]) (d3::Eq [Int]) (d4::Ix (q,r)++We /could/ generate+   RULE  f d1 d2 d3 d4 e1..en = $sf d1 d2 d3 d4+   $sf d1 d2 d3 d4 = <rhs> d1 d2 d3 d4++But that would do no specialisation at all! What we want is this:+   RULE  f d1 _d2 _d3 d4 e1..en = $sf d1 d4+   $sf d1 d4 =  let d7 = d1   -- Renaming+                    dx1 = d1  -- Renaming+                    d6 = d1   -- Renaming+                    d2 = $fOrdList d6+                    d3 = $fEqList $fEqInt+                in rhs d1 d2 d3 d4++Notice that:+  * We pass some, but not all, of the matched dictionaries to $sf++  * We get specialisations for d2 and d3, but not for d1, nor d4.++  * We had to introduce some renaming bindings at the top+    to line things up++The transformation goes in these steps++(S1) decomposeCall: decompose `the_call` into+     - `binds`: the enclosing let-bindings+     - `rule_lhs_args`: the arguments of the call itself++  If the expression in the SPECIALISE pragma had a type signature, such as+     SPECIALISE g :: Eq b => Int -> b -> b+  then the desugared expression may have type abstractions and applications+  "in the way", like this:+     (/\b. (\d:Eq b). let d1 = $dfOrdInt in f @Int @b d1 d) @b (d2:Eq b)+  The lambdas come from the type signature, which is then re-instantiated,+  hence the applications of those lambdas.++  To handle these, `decomposeCall` uses the simple optimiser to simplify+  this to+     let { d = d2; d1 = $dfOrdInt } in f @Int @b d1 d++  Wrinkle (S1a): do no inlining in this "simple optimiser" phase:+  use `simpleOptExprNoInline`. E.g. we don't want to turn it into+     f @Int @b $dfOrdInt d2+  because the latter is harder to match. Similarly if we have+     let { d1=d; d2=d } in f d1 d2+  we don't want to inline d1/d2 to get this+     f d d++  TL;DR: as a result the dictionary arguments of the actual call,+    `rule_lhs_args` are all distinct dictionary variables, not+    expressions.++(S2) Compute `rule_bndrs`: the free vars of `rule_lhs_args`, which+   will be the forall'd template variables of the RULE.  In the example,+       rule_bndrs = d1,d2,d3,d4+   These variables will get values from a successful RULE match.++(S3) `getRenamings`: starting from the rule_bndrs, make bindings for+   all other variables that are equal to them.  In the example, we+   make renaming-bindings for d7, dx1, d6.  Our goal is to bind+   as many variables as possible, by deducing them from `rule_bndrs`.+   If we have the binding+     d1 = d7  (where `d1` is a rule_bndr)+   we want to generate the renaming+     d7 = d1+   which instead deduces d7 from d1++   NB1: we don't actually have to remove the original bindings;+        it's harmless to leave them+   NB2: We also reverse bindings like  d1 = d2 |> co, to get+           d2 = d1 |> sym co+        It's easy and slightly improves our ability to get bindings+        for local variables from `rule_bndrs`. I'm not sure if it+        matters in practice, but it's easy to do.+   NB3: `getRenamings` works innermost first, so that we get transitivity.+        E.g in our example we have+                 d7 = dx1+                 d1 = d7     where d1 is rule_bndr+        `getRenamings` generate the renamings+                 dx1 = d1+                 d7 = d2++(S4) `pickSpecBinds`: pick the bindings we want to keep in the+   specialised function.  We start from `known_vars`, the variables we+   know, namely the `rule_bndrs` and the binders from (S3), which are+   all equal to one of the `rule_bndrs`.++   Then we keep a binding if the free vars of its RHS are all known.+   In our example, `d2` and `d3` are both picked, but `d4` is not.+   The non-picked ones won't end up being specialised.++(S5) Finally, work out which of the `rule_bndrs` we must pass on to+   specialised function. We just filter out ones bound by a renaming+   or a picked binding. -}  ------------------------@@ -802,121 +913,299 @@         -> TcSpecPrags         -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids                , [CoreRule] )           -- Rules for the Global Ids--- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind+-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig dsSpecs _ IsDefaultMethod = return (nilOL, []) dsSpecs poly_rhs (SpecPrags sps)-  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps+  = do { pairs <- mapMaybeM (dsLSpec poly_rhs) sps        ; let (spec_binds_s, rules) = unzip pairs        ; return (concatOL spec_binds_s, rules) } -dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding-                                -- Nothing => RULE is for an imported Id-                                --            rhs is in the Id's unfolding-       -> Located TcSpecPrag-       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))-dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))-  | isJust (isClassOpId_maybe poly_id)-  = putSrcSpanDs loc $-    do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)-       ; return Nothing  }  -- There is no point in trying to specialise a class op-                            -- Moreover, classops don't (currently) have an inl_sat arity set-                            -- (it would be Just 0) and that in turn makes makeCorePair bleat+dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])+dsImpSpecs imp_specs+ = do { spec_prs <- mapMaybeM spec_one imp_specs+      ; let (spec_binds, spec_rules) = unzip spec_prs+      ; return (concatOL spec_binds, spec_rules) }+ where+   spec_one (L loc prag) = putSrcSpanDs loc $+                           dsSpec (get_rhs prag) prag -  | no_act_spec && isNeverActive rule_act-  = putSrcSpanDs loc $-    do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)-       ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that-                            -- See Note [Activation pragmas for SPECIALISE]+   get_rhs (SpecPrag poly_id _ _)              = get_rhs1 poly_id+   get_rhs (SpecPragE { spe_fn_id = poly_id }) = get_rhs1 poly_id -  | otherwise-  = putSrcSpanDs loc $-    do { uniq <- newUnique-       ; let poly_name = idName poly_id-             spec_occ  = mkSpecOcc (getOccName poly_name)-             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)-             (spec_bndrs, spec_app) = collectHsWrapBinders spec_co+   get_rhs1 poly_id+    | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)+    = unfolding    -- Imported Id; this is its unfolding+                   -- Use realIdUnfolding so we get the unfolding+                   -- even when it is a loop breaker.+                   -- We want to specialise recursive functions!+    | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)+                  -- The type checker has checked that it *has* an unfolding++dsLSpec :: CoreExpr -> Located TcSpecPrag+        -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsLSpec poly_rhs (L loc prag)+  = putSrcSpanDs loc $ dsSpec poly_rhs prag++dsSpec :: CoreExpr   -- RHS to be specialised+       -> TcSpecPrag+       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl)+  -- SpecPrag case: See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig+  | (spec_bndrs, spec_app) <- collectHsWrapBinders spec_co                -- spec_co looks like                --         \spec_bndrs. [] spec_args                -- perhaps with the body of the lambda wrapped in some WpLets                -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2+  = dsHsWrapper spec_app $ \core_app ->+    dsSpec_help (idName poly_id) poly_id poly_rhs+                spec_inl spec_bndrs (core_app (Var poly_id)) -       ; dsHsWrapperForRuleLHS spec_app $ \core_app -> do+dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm+                           , spe_fn_id = poly_id+                           , spe_inl   = spec_inl+                           , spe_bndrs = bndrs+                           , spe_call  = the_call })+  -- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig+  = do { ds_call <- unsetGOptM Opt_EnableRewriteRules $ -- Note [Desugaring RULE left hand sides]+                    unsetWOptM Opt_WarnIdentities     $+                    zapUnspecables $+                    dsLExpr the_call+       ; dsSpec_help poly_nm poly_id poly_rhs spec_inl bndrs ds_call } -       { let ds_lhs  = core_app (Var poly_id)-             spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)-       ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id-         --                         , text "spec_co:" <+> ppr spec_co-         --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $-         dflags <- getDynFlags-       ; case decomposeRuleLhs dflags spec_bndrs ds_lhs (mkVarSet spec_bndrs) of {-           Left msg -> do { diagnosticDs msg; return Nothing } ;-           Right (rule_bndrs, _fn, rule_lhs_args) -> do+dsSpec_help :: Name -> Id -> CoreExpr              -- Function to specialise+            -> InlinePragma -> [Var] -> CoreExpr+            -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call+  = do { -- Decompose the call+         -- Step (S1) of Note [Desugaring new-form SPECIALISE pragmas]+         mb_call_info <- decomposeCall poly_id ds_call+       ; case mb_call_info of {+            Nothing -> return Nothing ;+            Just (binds, rule_lhs_args) -> -       { this_mod <- getModule-       ; let fn_unf    = realIdUnfolding poly_id+    do { dflags   <- getDynFlags+       ; this_mod <- getModule+       ; uniq     <- newUnique+       ; let locals = mkVarSet orig_bndrs `extendVarSetList` bindersOfBinds binds+             is_local :: Var -> Bool+             is_local v = v `elemVarSet` locals++             -- Find `rule_bndrs`: (S2) of Note [Desugaring new-form SPECIALISE pragmas]+             rule_bndrs = scopedSort (exprsSomeFreeVarsList is_local rule_lhs_args)++             -- getRenamings: (S3) of  Note [Desugaring new-form SPECIALISE pragmas]+             rn_binds     = getRenamings orig_bndrs binds rule_bndrs++             -- pickSpecBinds: (S4) of Note [Desugaring new-form SPECIALISE pragmas]+             known_vars   = mkVarSet rule_bndrs `extendVarSetList` bindersOfBinds rn_binds+             picked_binds = pickSpecBinds is_local known_vars binds++             -- Find `spec_bndrs`: (S5) of Note [Desugaring new-form SPECIALISE pragmas]+             -- Make spec_bndrs, the variables to pass to the specialised+             -- function, by filtering out the rule_bndrs that aren't needed+             spec_binds_bndr_set = mkVarSet (bindersOfBinds picked_binds)+                                   `minusVarSet` exprsFreeVars (rhssOfBinds rn_binds)+             spec_bndrs = filterOut (`elemVarSet` spec_binds_bndr_set) rule_bndrs++             mk_spec_body fn_body = mkLets (rn_binds ++ picked_binds)  $+                                    mkApps fn_body rule_lhs_args+                                    -- NB: not mkCoreApps!  That uses exprType on fun+                                    --     which fails in specUnfolding, sigh++             poly_name  = idName poly_id+             spec_occ   = mkSpecOcc (getOccName poly_name)+             spec_name  = mkInternalName uniq spec_occ (getSrcSpan poly_name)+             id_inl     = idInlinePragma poly_id+              simpl_opts = initSimpleOpts dflags-             spec_unf   = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf-             spec_id    = mkLocalId spec_name ManyTy spec_ty -- Specialised binding is toplevel, hence Many.-                            `setInlinePragma` inl_prag-                            `setIdUnfolding`  spec_unf+             fn_unf     = realIdUnfolding poly_id+             spec_unf   = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_lhs_args fn_unf+             spec_info  = vanillaIdInfo+                          `setInlinePragInfo` specFunInlinePrag poly_id id_inl spec_inl+                          `setUnfoldingInfo`  spec_unf+             spec_id    = mkLocalVar (idDetails poly_id) spec_name ManyTy spec_ty spec_info+                          -- Specialised binding is toplevel, hence Many. +             -- The RULE looks like+             --    RULE "USPEC" forall rule_bndrs. f rule_lhs_args = $sf spec_bndrs+             -- The specialised function looks like+             --    $sf spec_bndrs = mk_spec_body <f's original rhs>+             -- We also use mk_spec_body to specialise the methods in f's stable unfolding+             -- NB: spec_bindrs is a subset of rule_bndrs              rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")                                poly_id rule_bndrs rule_lhs_args                                (mkVarApps (Var spec_id) spec_bndrs)-             spec_rhs = mkLams spec_bndrs (core_app poly_rhs) -       ; dsWarnOrphanRule rule+             rule_ty  = exprType (mkApps (Var poly_id) rule_lhs_args)+             spec_ty  = mkLamTypes spec_bndrs rule_ty+             spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs) -       ; tracePm "dsSpec" (vcat-            [ text "fun:" <+> ppr poly_id-            , text "spec_co:" <+> ppr spec_co-            , text "spec_bndrs:" <+>  ppr spec_bndrs-            , text "ds_lhs:" <+> ppr ds_lhs-            , text "args:" <+>  ppr rule_lhs_args ])-       ; return (Just (unitOL (spec_id, spec_rhs), rule))+             result = (unitOL (spec_id, spec_rhs), rule)             -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because             --     makeCorePair overwrites the unfolding, which we have             --     just created using specUnfolding-       } } } }-  where-    is_local_id = isJust mb_poly_rhs-    poly_rhs | Just rhs <-  mb_poly_rhs-             = rhs          -- Local Id; this is its rhs-             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)-             = unfolding    -- Imported Id; this is its unfolding-                            -- Use realIdUnfolding so we get the unfolding-                            -- even when it is a loop breaker.-                            -- We want to specialise recursive functions!-             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)-                            -- The type checker has checked that it *has* an unfolding+       ; tracePm "dsSpec(new route)" $+         vcat [ text "poly_id" <+> ppr poly_id+              , text "unfolding" <+> ppr (realIdUnfolding poly_id)+              , text "orig_bndrs"   <+> pprCoreBinders orig_bndrs+              , text "locals" <+> ppr locals+              , text "fvs" <+> ppr (exprsSomeFreeVarsList is_local rule_lhs_args)+              , text "ds_call" <+> ppr ds_call+              , text "binds" <+> ppr binds+              , text "rule_lhs_args" <+> ppr rule_lhs_args+              , text "rule_bndrs" <+> ppr rule_bndrs+              , text "spec_bndrs" <+> ppr spec_bndrs+              , text "rn_binds" <+> ppr rn_binds+              , text "picked_binds" <+> ppr picked_binds ] -    id_inl = idInlinePragma poly_id+       ; dsWarnOrphanRule rule -    -- See Note [Activation pragmas for SPECIALISE]-    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl-             | not is_local_id  -- See Note [Specialising imported functions]-                                 -- in OccurAnal-             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma-             | otherwise                               = id_inl-     -- Get the INLINE pragma from SPECIALISE declaration, or,-     -- failing that, from the original Id+       ; case checkUselessSpecPrag poly_id rule_lhs_args spec_bndrs+                 no_act_spec spec_inl rule_act of+           Nothing -> return (Just result) -    spec_prag_act = inlinePragmaActivation spec_inl+           Just reason -> do { diagnosticDs $ DsUselessSpecialisePragma poly_nm is_dfun reason+                             ; if uselessSpecialisePragmaKeepAnyway reason+                               then return (Just result)+                               else return Nothing } } } } +  where     -- See Note [Activation pragmas for SPECIALISE]     -- no_act_spec is True if the user didn't write an explicit     -- phase specification in the SPECIALISE pragma+    id_inl        = idInlinePragma poly_id+    inl_prag_act  = inlinePragmaActivation id_inl+    spec_prag_act = inlinePragmaActivation spec_inl     no_act_spec = case inlinePragmaSpec spec_inl of                     NoInline _   -> isNeverActive  spec_prag_act                     Opaque _     -> isNeverActive  spec_prag_act                     _            -> isAlwaysActive spec_prag_act-    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit-             | otherwise   = spec_prag_act                   -- Specified by user+    rule_act | no_act_spec = inl_prag_act    -- Inherit+             | otherwise   = spec_prag_act   -- Specified by user +    is_dfun = case idDetails poly_id of+      DFunId {} -> True+      _ -> False +decomposeCall :: Id -> CoreExpr+              -> DsM (Maybe ([CoreBind], [CoreExpr] ))+-- Decompose the call into (let <binds> in f <args>)+-- See (S1) in Note [Desugaring new-form SPECIALISE pragmas]+decomposeCall poly_id ds_call+  = do { dflags  <- getDynFlags+       ; let simpl_opts = initSimpleOpts dflags+             core_call  = simpleOptExprNoInline simpl_opts ds_call+               -- simpleOptExprNoInline: see Wrinkle (S1a)!++       ; case go [] core_call of {+           Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)+                         ; return Nothing } ;+           Just result -> return (Just result) } }+  where+    go :: [CoreBind] -> CoreExpr -> Maybe ([CoreBind],[CoreExpr])+    go acc (Let bind body) = go (bind:acc) body+    go acc (Cast e _)      = go acc e  -- Discard outer casts+                                       -- ToDo: document this+    go acc e+      | (Var fun, args) <- collectArgs e+      = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $+        Just (reverse acc, args)+      | otherwise+      = Nothing++    -- Is this SPECIALISE pragma useless?+checkUselessSpecPrag :: Id -> [CoreExpr]+   -> [Var] -> Bool -> InlinePragma -> Activation+   ->  Maybe UselessSpecialisePragmaReason+checkUselessSpecPrag poly_id rule_lhs_args+                     spec_bndrs no_act_spec spec_inl rule_act+  | isJust (isClassOpId_maybe poly_id)+  -- There is no point in trying to specialise a class op+  -- Moreover, classops don't (currently) have an inl_sat arity set+  -- (it would be Just 0) and that in turn makes makeCorePair bleat+  = Just UselessSpecialiseForClassMethodSelector++  | no_act_spec, isNeverActive rule_act+  -- Function is NOINLINE, and the specialisation inherits that+  -- See Note [Activation pragmas for SPECIALISE]+  = Just UselessSpecialiseForNoInlineFunction++  | all is_nop_arg rule_lhs_args, not (isInlinePragma spec_inl)+  -- The specialisation does nothing.+  -- But don't complain if it is SPECIALISE INLINE (#4444)+  = Just UselessSpecialiseNoSpecialisation++  | otherwise+  = Nothing++  where+    is_nop_arg (Type {})     = True+    is_nop_arg (Coercion {}) = True+    is_nop_arg (Cast e _)    = is_nop_arg e+    is_nop_arg (Tick _ e)    = is_nop_arg e+    is_nop_arg (Var x)       = x `elem` spec_bndrs+    is_nop_arg _             = False+++getRenamings :: [Var] -> [CoreBind]  -- orig_bndrs and bindings+             -> [Var]                -- rule_bndrs+             -> [CoreBind]           -- Binds some of the orig_bndrs to a rule_bndr+getRenamings orig_bndrs binds rule_bndrs+  = [ NonRec b e | b <- orig_bndrs+                 , not (b `elem` rule_bndrs)+                 , Just e <- [lookupVarEnv final_renamings b] ]+  where+    init_renamings, final_renamings :: IdEnv CoreExpr+    -- In this function, IdEnv maps a local variable to (v |> co),+    -- where `v` is a rule_bndr++    init_renamings = mkVarEnv [ (v, Var v) | v <- rule_bndrs, isId v ]+    final_renamings = go binds++    go :: [CoreBind] -> IdEnv CoreExpr+    go [] = init_renamings+    go (bind : binds)+       | NonRec b rhs <- bind+       , Just (v, mco) <- getCastedVar rhs+       , Just e <- lookupVarEnv renamings b+       = extendVarEnv renamings v (mkCastMCo e (mkSymMCo mco))+       | otherwise+       = renamings+       where+         renamings = go binds++pickSpecBinds :: (Var -> Bool) -> VarSet -> [CoreBind] -> [CoreBind]+pickSpecBinds _ _ [] = []+pickSpecBinds is_local known_bndrs (bind:binds)+      | all keep_me (rhssOfBind bind)+      , let known_bndrs' = known_bndrs `extendVarSetList` bindersOf bind+      = bind : pickSpecBinds is_local known_bndrs' binds+      | otherwise+      = pickSpecBinds is_local known_bndrs binds+      where+        keep_me rhs = isEmptyVarSet (exprSomeFreeVars bad_var rhs)+        bad_var v = is_local v && not (v `elemVarSet` known_bndrs)++getCastedVar :: CoreExpr -> Maybe (Var, MCoercionR)+getCastedVar (Var v)           = Just (v, MRefl)+getCastedVar (Cast (Var v) co) = Just (v, MCo co)+getCastedVar _                 = Nothing++specFunInlinePrag :: Id -> InlinePragma+                  -> InlinePragma -> InlinePragma+-- See Note [Activation pragmas for SPECIALISE]+specFunInlinePrag poly_id id_inl spec_inl+  | not (isDefaultInlinePragma spec_inl)    = spec_inl+  | isGlobalId poly_id  -- See Note [Specialising imported functions]+                        -- in OccurAnal+  , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma+  | otherwise                               = id_inl+     -- Get the INLINE pragma from SPECIALISE declaration, or,+     -- failing that, from the original Id+ dsWarnOrphanRule :: CoreRule -> DsM () dsWarnOrphanRule rule-  = when (isOrphan (ru_orphan rule)) $+  = when (ruleIsOrphan rule) $     diagnosticDs (DsOrphanRule rule)  {- Note [SPECIALISE on INLINE functions]@@ -995,64 +1284,63 @@   = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]    | otherwise = case decompose fun2 args2 of-        Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs-                   --                                    , text "orig_lhs:" <+> ppr orig_lhs-                   --                                    , text "rhs_fvs:" <+> ppr rhs_fvs-                   --                                    , text "orig_lhs:" <+> ppr orig_lhs-                   --                                    , text "lhs1:" <+> ppr lhs1-                   --                                    , text "lhs2:" <+> ppr lhs2-                   --                                    , text "fun2:" <+> ppr fun2-                   --                                    , text "args2:" <+> ppr args2-                   --                                    ]) $+        Nothing ->  -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+                    --                                   , text "orig_lhs:" <+> ppr orig_lhs+                    --                                   , text "rhs_fvs:" <+> ppr rhs_fvs+                    --                                   , text "lhs1:" <+> ppr lhs1+                    --                                   , text "lhs2:" <+> ppr lhs2+                    --                                   , text "fun2:" <+> ppr fun2+                    --                                   , text "args2:" <+> ppr args2+                    --                                   ]) $                    Left (DsRuleLhsTooComplicated orig_lhs lhs2)+         Just (fn_id, args)           | not (null unbound) ->             -- Check for things unbound on LHS             -- See Note [Unused spec binders]-            -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs-            --                                     , text "orig_lhs:" <+> ppr orig_lhs-            --                                     , text "lhs_fvs:" <+> ppr lhs_fvs-            --                                     , text "rhs_fvs:" <+> ppr rhs_fvs-            --                                     , text "unbound:" <+> ppr unbound-            --                                     ]) $+             -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+             --                                    , text "orig_lhs:" <+> ppr orig_lhs+             --                                    , text "lhs_fvs:" <+> ppr lhs_fvs+             --                                    , text "rhs_fvs:" <+> ppr rhs_fvs+             --                                    , text "unbound:" <+> ppr unbound+             --                                    ]) $             Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2)           | otherwise ->             -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs-            --                                    , text "orig_lhs:" <+> ppr orig_lhs-            --                                    , text "lhs1:"     <+> ppr lhs1-            --                                    , text "extra_bndrs:" <+> ppr extra_bndrs-            --                                    , text "fn_id:" <+> ppr fn_id-            --                                    , text "args:"   <+> ppr args-            --                                    , text "args fvs:" <+> ppr (exprsFreeVarsList args)-            --                                    ]) $-            Right (trimmed_bndrs ++ extra_bndrs, fn_id, args)+            --                                   , text "orig_lhs:" <+> ppr orig_lhs+            --                                   , text "lhs1:"     <+> ppr lhs1+            --                                   , text "trimmed_bndrs:" <+> ppr trimmed_bndrs+            --                                   , text "extra_dicts:" <+> ppr extra_dicts+            --                                   , text "fn_id:" <+> ppr fn_id+            --                                   , text "args:"   <+> ppr args+            --                                   , text "args fvs:" <+> ppr (exprsFreeVarsList args)+            --                                   ]) $+            Right (trimmed_bndrs ++ extra_dicts, fn_id, args)            where -- See Note [Variables unbound on the LHS]-                lhs_fvs = exprsFreeVars args+                lhs_fvs       = exprsFreeVars args                 all_fvs       = lhs_fvs `unionVarSet` rhs_fvs                 trimmed_bndrs = filter (`elemVarSet` all_fvs) orig_bndrs                 unbound       = filterOut (`elemVarSet` lhs_fvs) trimmed_bndrs                     -- Needed on RHS but not bound on LHS -                -- Add extra tyvar binders: Note [Free tyvars on rule LHS]-                -- and extra dict binders: Note [Free dictionaries on rule LHS]-                extra_bndrs = scopedSort extra_tvs ++ extra_dicts-                  where-                    extra_tvs   = [ v | v <- extra_vars, isTyVar v ]+                -- extra_dicts: see Note [Free dictionaries on rule LHS]+-- ToDo: extra_dicts is needed. E.g. the SPECIALISE rules for `ap` in GHC.Base+                extra_dicts+                  = [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d)+                    | d <- exprsSomeFreeVarsList is_extra args ] -                -- isEvVar: this includes coercions, matching what-                --          happens in `split_lets` (isDictId, isCoVar)-                extra_dicts =-                  [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d)-                    | d <- extra_vars, isEvVar d ]-                extra_vars  =-                  [ v-                  | v <- exprsFreeVarsList args-                  , not (v `elemVarSet` orig_bndr_set)-                  , not (v == fn_id) ]-                    -- fn_id: do not quantify over the function itself, which may-                    -- itself be a dictionary (in pathological cases, #10251)+                is_extra v+                  = isSimplePredTy (idType v)+                      -- isSimplePredTy: includes coercions and dictionaries+                      -- But NOT dictionary functions; and in particular not+                      -- superclass-selector fuctions +                    && not (v `elemVarSet` orig_bndr_set)+                    && not (v == fn_id)+                       -- fn_id: do not quantify over the function itself, which may+                       -- itself be a dictionary (in pathological cases, #10251)+  where    simpl_opts    = initSimpleOpts dflags    orig_bndr_set = mkVarSet orig_bndrs@@ -1079,9 +1367,10 @@     split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)    split_lets (Let (NonRec d r) body)-     | isDictId d  -- Catches dictionaries, yes, but also catches dictionary-                   -- /functions/ arising from solving a-                   -- quantified contraint (#24370)+     | isPredTy (idType d)+       -- isPredTy: catches dictionaries, yes, but also catches+       -- dictionary /functions/ arising from solving a+       -- quantified contraint (see #24370)      = ((d,r):bs, body')      where (bs, body') = split_lets body @@ -1116,7 +1405,7 @@  We get two dicts on the LHS, one from `1` and one from `+`. For reasons described in Note [The SimplifyRule Plan] in-GHC.Tc.Gen.Rule, we quantify separately over those dictionaries:+GHC.Tc.Gen.Sig, we quantify separately over those dictionaries:    forall f (d1::Num Int) (d2 :: Num Int).    foo (\xs. (+) d1 (fromInteger d2 1) xs) = ... @@ -1131,32 +1420,6 @@ * simpleOptExpr: see Note [Simplify rule LHS] * extra_dict_bndrs: see Note [Free dictionaries on rule LHS] -Note [Free tyvars on rule LHS]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  data T a = C--  foo :: T a -> Int-  foo C = 1--  {-# RULES "myrule"  foo C = 1 #-}--After type checking the LHS becomes (foo alpha (C alpha)), where alpha-is an unbound meta-tyvar.  The zonker in GHC.Tc.Zonk.Type is careful not to-turn the free alpha into Any (as it usually does).  Instead it turns it-into a TyVar 'a'.  See Note [Zonking the LHS of a RULE] in "GHC.Tc.Zonk.Type".--Now we must quantify over that 'a'.  It's /really/ inconvenient to do that-in the zonker, because the HsExpr data type is very large.  But it's /easy/-to do it here in the desugarer.--Moreover, we have to do something rather similar for dictionaries;-see Note [Free dictionaries on rule LHS].   So that's why we look for-type variables free on the LHS, and quantify over them.--This relies on there not being any in-scope tyvars, which is true for-user-defined RULEs, which are always top-level.- Note [Free dictionaries on rule LHS] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,@@ -1191,9 +1454,9 @@    quantify over it. That makes 'd' free in the LHS, but that is later    picked up by extra_dict_bndrs (see Note [Unused spec binders]). -   NB 1: We can only drop the binding if the RHS doesn't bind-         one of the orig_bndrs, which we assume occur on RHS.-         Example+   NB 1: We can only drop the binding if the RHS of the binding doesn't+         mention one of the orig_bndrs, which we assume occur on RHS of+         the rule.  Example             f :: (Eq a) => b -> a -> a             {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}          Here we want to end up with@@ -1201,7 +1464,7 @@          Of course, the ($dfEqlist d) in the pattern makes it less likely          to match, but there is no other way to get d:Eq a -   NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all+   NB 2: We do drop_dicts *before* simplOptExpr, so that we expect all          the evidence bindings to be wrapped around the outside of the          LHS.  (After simplOptExpr they'll usually have been inlined.)          dsHsWrapper does dependency analysis, so that civilised ones@@ -1312,49 +1575,6 @@  This question arose when thinking about deep subsumption; see https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649).--Note [Desugaring non-canonical evidence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the evidence is canonical, we desugar WpEvApp by simply passing-core_tm directly to k:--  k core_tm--If the evidence is not canonical, we mark the application with nospec:--  nospec @(cls => a) k core_tm--where  nospec :: forall a. a -> a  ensures that the typeclass specialiser-doesn't attempt to common up this evidence term with other evidence terms-of the same type (see Note [nospecId magic] in GHC.Types.Id.Make).--See Note [Coherence and specialisation: overview] for why we shouldn't-specialise incoherent evidence.--We can find out if a given evidence is canonical or not during the-desugaring of its WpLet wrapper: an evidence is non-canonical if its-own resolution was incoherent (see Note [Incoherent instances]), or-if its definition refers to other non-canonical evidence. dsEvBinds is-the convenient place to compute this, since it already needs to do-inter-evidence dependency analysis to generate well-scoped-bindings. We then record this specialisability information in the-dsl_unspecables field of DsM's local environment.--Wrinkle:--(NC1) Don't do this in the LHS of a RULE.  In paritcular, if we have-     f :: (Num a, HasCallStack) => a -> a-     {-# SPECIALISE f :: Int -> Int #-}-  then making a rule like-        RULE   forall d1:Num Int, d2:HasCallStack.-               f @Int d1 d2 = $sf-  is pretty dodgy, because $sf won't get the call stack passed in d2.-  But that's what you asked for in the SPECIALISE pragma, so we'll obey.--  We definitely can't desugar that LHS into this!-      nospec (f @Int d1) d2--  Hence the `is_rule_lhs` flag in `ds_hs_wrapper`. -}  dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a@@ -1362,17 +1582,22 @@ dsHsWrappers []       k = k []  dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a-dsHsWrapper = ds_hs_wrapper False--dsHsWrapperForRuleLHS :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a-dsHsWrapperForRuleLHS = ds_hs_wrapper True+dsHsWrapper hs_wrap thing_inside+  = ds_hs_wrapper hs_wrap $ \ core_wrap ->+    addTyCs FromSource (hsWrapDictBinders hs_wrap) $+       -- addTyCs: Add type evidence to the refinement type+       --            predicate of the coverage checker+       --   See Note [Long-distance information] in "GHC.HsToCore.Pmc"+       -- FromSource might not be accurate (we don't have any+       -- origin annotations for things in this module), but at+       -- worst we do superfluous calls to the pattern match+       -- oracle.+    thing_inside core_wrap -ds_hs_wrapper :: Bool    -- True <=> LHS of a RULE-                         -- See (NC1) in Note [Desugaring non-canonical evidence]-              -> HsWrapper+ds_hs_wrapper :: HsWrapper               -> ((CoreExpr -> CoreExpr) -> DsM a)               -> DsM a-ds_hs_wrapper is_rule_lhs wrap = go wrap+ds_hs_wrapper wrap = go wrap   where     go WpHole            k = k $ \e -> e     go (WpTyApp ty)      k = k $ \e -> App e (Type ty)@@ -1380,6 +1605,8 @@     go (WpTyLam tv)      k = k $ Lam tv     go (WpCast co)       k = assert (coercionRole co == Representational) $                              k $ \e -> mkCastDs e co+    go (WpEvApp tm)      k = do { core_tm <- dsEvTerm tm+                                ; k $ \e -> e `App` core_tm }     go (WpLet ev_binds)  k = dsTcEvBinds ev_binds $ \bs ->                              k (mkCoreLets bs)     go (WpCompose c1 c2) k = go c1 $ \w1 ->@@ -1389,38 +1616,10 @@                              do { x <- newSysLocalDs st                                 ; go c1 $ \w1 ->                                   go c2 $ \w2 ->-                                  let app f a = mkCoreAppDs (text "dsHsWrapper") f a+                                  let app f a = mkCoreApp (text "dsHsWrapper") f a                                       arg     = w1 (Var x)                                   in k (\e -> (Lam x (w2 (app e arg)))) }-    go (WpEvApp tm)      k = do { core_tm <- dsEvTerm tm -                                  -- See Note [Desugaring non-canonical evidence]-                                ; unspecables <- getUnspecables-                                ; let vs = exprFreeVarsList core_tm-                                      is_unspecable_var v = v `S.member` unspecables-                                      is_specable-                                        | is_rule_lhs = True-                                        | otherwise   = not $ any (is_unspecable_var) vs--                                ; k (\e -> app_ev is_specable e core_tm) }--  -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.-    go (WpMultCoercion co) k = do { unless (isReflexiveCo co) $-                                    diagnosticDs DsMultiplicityCoercionsNotSupported-                                  ; k $ \e -> e }---- We are about to construct an evidence application `f dict`.  If the dictionary is--- non-specialisable, instead construct---     nospec f dict--- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does.-app_ev :: Bool -> CoreExpr -> CoreExpr -> CoreExpr-app_ev is_specable k core_tm-    | not is_specable-    = Var nospecId `App` Type (exprType k) `App` k `App` core_tm--    | otherwise-    = k `App` core_tm- -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a dsTcEvBinds_s []       k = k []@@ -1449,29 +1648,34 @@                thing_inside (core_bind:core_binds) }     go [] thing_inside = thing_inside [] -    ds_component unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)+    ds_component mb_unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)       where         ((v, rhs), (this_canonical, deps)) = unpack_node node-        transitively_unspecable = is_unspecable this_canonical || any is_unspecable_dep deps-        is_unspecable_dep dep = dep `S.member` unspecables-        new_unspecables-            | transitively_unspecable = S.singleton v-            | otherwise = mempty-    ds_component unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)+        new_unspecables = case mb_unspecables of+           Nothing                                -> []+           Just unspecs | transitively_unspecable -> [v]+                        | otherwise               -> []+              where+                transitively_unspecable = is_unspecable this_canonical+                                          || any (`elemVarSet` unspecs) deps++    ds_component mb_unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)       where         (pairs, direct_canonicity) = unzip $ map unpack_node nodes -        is_unspecable_remote dep = dep `S.member` unspecables-        transitively_unspecable = or [ is_unspecable this_canonical || any is_unspecable_remote deps-                                     | (this_canonical, deps) <- direct_canonicity ]+        new_unspecables = case mb_unspecables of+           Nothing                                -> []+           Just unspecs | transitively_unspecable -> map fst pairs+                        | otherwise               -> []+              where+                 transitively_unspecable+                   = or [ is_unspecable this_canonical+                          || any (`elemVarSet` unspecs) deps+                        | (this_canonical, deps) <- direct_canonicity ]             -- Bindings from a given SCC are transitively specialisable if             -- all are specialisable and all their remote dependencies are             -- also specialisable; see Note [Desugaring non-canonical evidence] -        new_unspecables-            | transitively_unspecable = S.fromList [ v | (v, _) <- pairs]-            | otherwise = mempty-     unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps }        = ((v, rhs), (canonical, deps)) @@ -1520,10 +1724,10 @@ dsEvTerm (EvTypeable ty ev)  = dsEvTypeable ty ev dsEvTerm (EvFun { et_tvs = tvs, et_given = given                 , et_binds = ev_binds, et_body = wanted_id })-  = do { dsTcEvBinds ev_binds $ \ds_ev_binds -> do-       { return $ (mkLams (tvs ++ given) $+  = do { dsTcEvBinds ev_binds $ \ds_ev_binds ->+         return $ (mkLams (tvs ++ given) $                    mkCoreLets ds_ev_binds $-                   Var wanted_id) } }+                   Var wanted_id) }   {-**********************************************************************
− compiler/GHC/HsToCore/Breakpoints.hs 
@@ -1,63 +0,0 @@-module GHC.HsToCore.Breakpoints-  ( mkModBreaks-  ) where--import GHC.Prelude--import qualified GHC.Runtime.Interpreter as GHCi-import GHC.Runtime.Interpreter.Types-import GHCi.RemoteTypes-import GHC.ByteCode.Types-import GHC.Stack.CCS-import GHC.Unit--import GHC.HsToCore.Ticks (Tick (..))--import GHC.Data.SizedSeq-import GHC.Utils.Outputable as Outputable--import Data.List (intersperse)-import Data.Array---- | Initialize memory for breakpoint data that is shared between the bytecode--- generator and the interpreter.------ Since GHCi and the RTS need to interact with breakpoint data and the bytecode--- generator needs to encode this information for each expression, the data is--- allocated remotely in GHCi's address space and passed to the codegen as--- foreign pointers.-mkModBreaks :: Interp -> Module -> SizedSeq Tick -> IO ModBreaks-mkModBreaks interp mod extendedMixEntries-  = do-    let count = fromIntegral $ sizeSS extendedMixEntries-        entries = ssElts extendedMixEntries--    breakArray <- GHCi.newBreakArray interp count-    ccs <- mkCCSArray interp mod count entries-    mod_ptr <- GHCi.newModuleName interp (moduleName mod)-    let-           locsTicks  = listArray (0,count-1) [ tick_loc  t | t <- entries ]-           varsTicks  = listArray (0,count-1) [ tick_ids  t | t <- entries ]-           declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]-    return $ emptyModBreaks-                       { modBreaks_flags  = breakArray-                       , modBreaks_locs   = locsTicks-                       , modBreaks_vars   = varsTicks-                       , modBreaks_decls  = declsTicks-                       , modBreaks_ccs    = ccs-                       , modBreaks_module = mod_ptr-                       }--mkCCSArray-  :: Interp -> Module -> Int -> [Tick]-  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))-mkCCSArray interp modul count entries-  | GHCi.interpreterProfiled interp = do-      let module_str = moduleNameString (moduleName modul)-      costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)-      return (listArray (0,count-1) costcentres)-  | otherwise = return (listArray (0,-1) [])- where-    mk_one t = (name, src)-      where name = concat $ intersperse "." $ tick_path t-            src = renderWithContext defaultSDocContext $ ppr $ tick_loc t
compiler/GHC/HsToCore/Docs.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}  module GHC.HsToCore.Docs where @@ -29,7 +30,7 @@ import qualified Data.Map as M import qualified Data.Set as Set import Data.Maybe-import Data.Semigroup+import qualified Data.Semigroup as S import GHC.IORef (readIORef) import GHC.Unit.Types import GHC.Hs@@ -41,6 +42,8 @@ import GHC.Types.TypeEnv import GHC.Types.Id import GHC.Types.Unique.Map+import GHC.Utils.Outputable+import GHC.Utils.Panic  -- | Extract docs from renamer output. -- This is monadic since we need to be able to read documentation added from@@ -184,7 +187,7 @@     -- Map from aliases to true module names.     aliasMap :: Map ModuleName (NonEmpty ModuleName)     aliasMap =-        M.fromListWith (<>) $+        M.fromListWith (S.<>) $           (this_mdl_name, this_mdl_name :| [])           : (flip concatMap (M.toList imported) $ \(mdl, imvs) ->               [(imv_name imv, moduleName mdl :| []) | imv <- imvs])@@ -257,7 +260,7 @@        -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn))) mkMaps env instances decls =     ( listsToMapWith (++) (map (nubByName fst) decls')-    , listsToMapWith (<>) (filterMapping (not . IM.null) args)+    , listsToMapWith (S.<>) (filterMapping (not . IM.null) args)     )   where     (decls', args) = unzip (map mappings decls)@@ -377,8 +380,8 @@    InstD _ (DataFamInstD _ (DataFamInstDecl d))     -> dataSubs (feqn_rhs d)-  TyClD _ d | isClassDecl d -> classSubs d-            | isDataDecl  d -> dataSubs (tcdDataDefn d)+  TyClD _ d | ClassDecl{} <- d -> classSubs d+            | DataDecl{} <- d  -> dataSubs (tcdDataDefn d)   _ -> []   where     classSubs dd = [ (name, doc, declTypeDocs d)@@ -396,7 +399,7 @@                   | c <- toList cons, cname <- getConNames c ]         fields  = [ (unLoc $ foLabel n, maybeToList $ fmap unLoc doc, IM.empty)                   | Just flds <- toList $ fmap getRecConArgs_maybe cons-                  , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)+                  , (L _ (HsConDeclRecField _ ns (CDF { cdf_doc = doc }))) <- (unLoc flds)                   , (L _ n) <- ns ]         derivs  = [ (instName, [unLoc doc], IM.empty)                   | (l, doc) <- concatMap (extract_deriv_clause_tys .@@ -427,21 +430,23 @@  h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn) h98ConArgDocs con_args = case con_args of-  PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args-  InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)-                                       , unLoc (hsScaledThing arg2) ]+  PrefixCon args     -> con_arg_docs 0 $ map cdf_doc args+  InfixCon arg1 arg2 -> con_arg_docs 0 [ cdf_doc arg1, cdf_doc arg2 ]   RecCon _           -> IM.empty  gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn) gadtConArgDocs con_args res_ty = case con_args of-  PrefixConGADT _ args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]-  RecConGADT _ _       -> con_arg_docs 1 [res_ty]+  PrefixConGADT _ args -> con_arg_docs 0 $ map cdf_doc args ++ [res_doc]+  RecConGADT _ _       -> con_arg_docs 1 [res_doc]+  where+    res_doc = case res_ty of+      HsDocTy _ _ lds -> Just lds+      _               -> Nothing -con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn)+con_arg_docs :: Int -> [Maybe (LHsDoc GhcRn)] -> IntMap (HsDoc GhcRn) con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]   where-    f n (HsDocTy _ _ lds) = Just (n, unLoc lds)-    f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)+    f n (Just lds) = Just (n, unLoc lds)     f _ _ = Nothing  isValD :: HsDecl a -> Bool@@ -450,15 +455,21 @@  -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists.-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])]-classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls-  where-    decls = docs ++ defs ++ sigs ++ ats-    docs  = mkDecls tcdDocs (DocD noExtField) class_-    defs  = mkDecls tcdMeths (ValD noExtField) class_-    sigs  = mkDecls tcdSigs (SigD noExtField) class_-    ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_+classDecls :: TyClDecl GhcRn  -- Always a ClassDecl+           -> [(LHsDecl GhcRn, [HsDoc GhcRn])]+classDecls decl+  | ClassDecl { .. } <- decl+  , let decls = docs ++ defs ++ sigs ++ ats+        docs  = mkDecls (DocD noExtField) tcdDocs+        defs  = mkDecls (ValD noExtField) tcdMeths+        sigs  = mkDecls (SigD noExtField) tcdSigs+        ats   = mkDecls (TyClD noExtField . FamDecl noExtField) tcdATs +  = filterDecls . collectDocs . sortLocatedA $ decls++  | otherwise+  = pprPanic "classDecls" (ppr decl)+ -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn) declTypeDocs = \case@@ -503,15 +514,15 @@  -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]-ungroup group_ =-  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField)  group_ ++-  mkDecls hs_derivds             (DerivD noExtField) group_ ++-  mkDecls hs_defds               (DefD noExtField)   group_ ++-  mkDecls hs_fords               (ForD noExtField)   group_ ++-  mkDecls hs_docs                (DocD noExtField)   group_ ++-  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField)  group_ ++-  mkDecls (typesigs . hs_valds)  (SigD noExtField)   group_ ++-  mkDecls (valbinds . hs_valds)  (ValD noExtField)   group_+ungroup (HsGroup {..}) =+  mkDecls (TyClD noExtField) (tyClGroupTyClDecls hs_tyclds)  +++  mkDecls (DerivD noExtField) hs_derivds +++  mkDecls (DefD noExtField)   hs_defds +++  mkDecls (ForD noExtField)   hs_fords +++  mkDecls (DocD noExtField)   hs_docs +++  mkDecls (InstD noExtField)  (tyClGroupInstDecls hs_tyclds) +++  mkDecls (SigD noExtField)   (typesigs  hs_valds) +++  mkDecls (ValD noExtField)   (valbinds hs_valds)   where     typesigs :: HsValBinds GhcRn -> [LSig GhcRn]     typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig@@ -573,11 +584,10 @@  -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor-mkDecls :: (struct -> [GenLocated l decl])-        -> (decl -> hsDecl)-        -> struct+mkDecls :: (decl -> hsDecl)+        -> [GenLocated l decl]         -> [GenLocated l hsDecl]-mkDecls field con = map (fmap con) . field+mkDecls con = map (fmap con)  -- | Extracts out individual maps of documentation added via Template Haskell's -- @putDoc@.
compiler/GHC/HsToCore/Expr.hs view
@@ -1,6 +1,6 @@- {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# LANGUAGE LambdaCase #-}@@ -30,44 +30,53 @@ import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc+import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Errors.Types-import GHC.Types.SourceText-import GHC.Types.Name hiding (varName)-import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote import GHC.HsToCore.Ticks (stripTicksTopHsExpr) import GHC.Hs + -- NB: The desugarer, which straddles the source and Core worlds, sometimes --     needs to see source types import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad+import GHC.Tc.Instance.Class (lookupHasFieldLabel)++import GHC.Core+import GHC.Core.FVs( exprsFreeVarsList )+import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.Core.Type import GHC.Core.TyCo.Rep-import GHC.Core import GHC.Core.Utils import GHC.Core.Make+import GHC.Core.PatSyn  import GHC.Driver.Session++import GHC.Types.SourceText+import GHC.Types.Name hiding (varName) import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Id.Make+import GHC.Types.Var( isInvisibleAnonPiTyBinder )+import GHC.Types.Var.Set( isEmptyVarSet, elemVarSet )+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Tickish+ import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Builtin.Types import GHC.Builtin.Names-import GHC.Types.Basic-import GHC.Types.SrcLoc-import GHC.Types.Tickish+ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Core.PatSyn import Control.Monad-import GHC.Types.Error  {- ************************************************************************@@ -101,9 +110,12 @@         ; foldrM ds_ip_bind inner ip_binds } }   where     ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr+    -- Given (IPBind n s e), we have+    --     n :: IP s ty, e :: ty+    -- Use evWrapIP to convert `e` (the user-written RHS) to an IP dictionary     ds_ip_bind (L _ (IPBind n _ e)) body       = do e' <- dsLExpr e-           return (Let (NonRec n e') body)+           return (Let (NonRec n (evWrapIPE (idType n) e')) body)  ------------------------- -- caller sets location@@ -226,8 +238,8 @@                -- so must be simply unboxed   = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun) noAnn) Nothing matches        ; massert (null args) -- Functions aren't unlifted-       ; dsHsWrapper co_fn $ \core_wrap -> do -- Can be non-identity (#21516)-       { let rhs' = core_wrap (mkOptTickBox tick rhs)+       ; dsHsWrapper co_fn $ \core_wrap ->  -- Can be non-identity (#21516)+    do { let rhs' = core_wrap (mkOptTickBox tick rhs)        ; return (bindNonRec fun rhs' body) } }  dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss@@ -259,23 +271,20 @@  -- | Desugar a typechecked expression. dsExpr :: HsExpr GhcTc -> DsM CoreExpr-dsExpr (HsVar    _ (L _ id))           = dsHsVar id +dsExpr e@(HsVar {})                 = dsApp e+dsExpr e@(HsApp {})                 = dsApp e+dsExpr e@(HsAppType {})             = dsApp e -dsExpr (HsUnboundVar (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref-        -- See Note [Holes] in GHC.Tc.Types.Constraint+dsExpr (HsHole (_, (HER ref _ _))) = dsEvTerm =<< readMutVar ref+      -- See Note [Holes in expressions] in GHC.Tc.Types.Constraint.  dsExpr (HsPar _ e)            = dsLExpr e dsExpr (ExprWithTySig _ e _)  = dsLExpr e -dsExpr (HsIPVar x _)          = dataConCantHappen x--dsExpr (HsGetField x _ _)     = dataConCantHappen x-dsExpr (HsProjection x _)     = dataConCantHappen x- dsExpr (HsLit _ lit)   = do { warnAboutOverflowedLit lit-       ; dsLit (convertLit lit) }+       ; dsLit lit }  dsExpr (HsOverLit _ lit)   = do { warnAboutOverflowedOverLit lit@@ -283,12 +292,14 @@  dsExpr e@(XExpr ext_expr_tc)   = case ext_expr_tc of+      HsRecSelTc {} -> dsApp e+      WrapExpr {}   -> dsApp e+      ConLikeTc {}  -> dsApp e+       ExpandedThingTc o e         | OrigStmt (L loc _) <- o         -> putSrcSpanDsA loc $ dsExpr e         | otherwise -> dsExpr e-      WrapExpr {}                    -> dsHsWrapped e-      ConLikeTc con tvs tys          -> dsConLike con tvs tys       -- Hpc Support       HsTick tickish e -> do         e' <- dsLExpr e@@ -306,36 +317,9 @@         do { assert (exprType e2 `eqType` boolTy)             mkBinaryTickBox ixT ixF e2           }-        {- Record selectors are warned about if they are not-        present in all of the parent data type's constructor,-        or always in case of pattern synonym record selectors-        (regulated by a flag). However, this only produces-        a warning if it's not a part of a record selector-        application. For example: -                data T = T1 | T2 {s :: Bool}-                f x = s x -- the warning from this case will be supressed -        See the `HsApp` case for where it is filtered out-        -}-      (HsRecSelTc (FieldOcc _ (L _ id))) ->-        do { let  name = getName id-                  RecSelId {sel_cons = (_, cons_wo_field)} = idDetails id-            ; cons_trimmed <- trim_cons cons_wo_field-            ; unless (null cons_wo_field) $ diagnosticDs-                  $ DsIncompleteRecordSelector name cons_trimmed (cons_trimmed /= cons_wo_field)-                      -- This only produces a warning if it's not a part of a-                      -- record selector application (e.g. `s a` where `s` is a selector)-                      -- See the `HsApp` case for where it is filtered out-            ; dsHsVar id }-          where-            trim_cons :: [ConLike] -> DsM [ConLike]-            trim_cons cons_wo_field = do-              dflags <- getDynFlags-              let maxConstructors = maxUncoveredPatterns dflags-              return $ take maxConstructors cons_wo_field - -- Strip ticks due to #21701, need to be invariant about warnings we produce whether -- this is enabled or not. dsExpr (NegApp _ (L loc@@ -346,7 +330,6 @@                 -- See Note [Checking "negative literals"]               (lit { ol_val = HsIntegral (negateIntegralLit i) })           ; dsOverLit lit }-       ;        ; dsSyntaxExpr neg_expr [mkTicks ts expr'] }  dsExpr (NegApp _ expr neg_expr)@@ -356,32 +339,7 @@ dsExpr (HsLam _ variant a_Match)   = uncurry mkCoreLams <$> matchWrapper (LamAlt variant) Nothing a_Match -dsExpr e@(HsApp _ fun arg)-         -- We want to have a special case that uses the PMC information to filter-         -- out some of the incomplete record selectors warnings and not trigger-         -- the warning emitted during the desugaring of dsExpr(HsRecSel)-         -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc-  = do { (msgs, fun') <- captureMessagesDs $ dsLExpr fun-             -- Make sure to filter out the generic incomplete record selector warning-             -- if it's a raw record selector-       ; arg' <- dsLExpr arg-       ; case getIdFromTrivialExpr_maybe fun' of-           Just fun_id | isRecordSelector fun_id-             -> do { let msgs' = filterMessages is_incomplete_rec_sel_msg msgs-                   ; addMessagesDs msgs'-                   ; pmcRecSel fun_id arg' }-           _ -> addMessagesDs msgs-       ; warnUnusedBindValue fun arg (exprType arg')-       ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }-  where-    is_incomplete_rec_sel_msg :: MsgEnvelope DsMessage -> Bool-    is_incomplete_rec_sel_msg (MsgEnvelope {errMsgDiagnostic = DsIncompleteRecordSelector{}})-                                = False-    is_incomplete_rec_sel_msg _ = True --dsExpr e@(HsAppType {}) = dsHsWrapped e- {- Note [Checking "negative literals"] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -441,13 +399,17 @@ dsExpr (ExplicitSum types alt arity expr)   = mkCoreUnboxedSum arity alt types <$> dsLExpr expr -dsExpr (HsPragE _ prag expr) =-  ds_prag_expr prag expr--dsExpr (HsEmbTy x _) = dataConCantHappen x-dsExpr (HsQual x _ _) = dataConCantHappen x-dsExpr (HsForAll x _ _) = dataConCantHappen x-dsExpr (HsFunArr x _ _ _) = dataConCantHappen x+dsExpr (HsPragE _ (HsPragSCC _ cc) expr)+  = do { dflags <- getDynFlags+       ; if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags+         then do+            mod_name <- getModule+            count <- goptM Opt_ProfCountEntries+            let nm = sl_fs cc+            flavour <- mkExprCCFlavour <$> getCCIndexDsM nm+            Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True)+                 <$> dsLExpr expr+         else dsLExpr expr }  dsExpr (HsCase ctxt discrim matches)   = do { core_discrim <- dsLExpr discrim@@ -463,11 +425,11 @@ -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. ---dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty+dsExpr (HsDo res_ty ListComp          (L _ stmts)) = dsListComp stmts res_ty+dsExpr (HsDo _      MonadComp         (L _ stmts)) = dsMonadComp stmts dsExpr (HsDo res_ty ctx@DoExpr{}      (L _ stmts)) = dsDo ctx stmts res_ty dsExpr (HsDo res_ty ctx@GhciStmtCtxt  (L _ stmts)) = dsDo ctx stmts res_ty dsExpr (HsDo res_ty ctx@MDoExpr{}     (L _ stmts)) = dsDo ctx stmts res_ty-dsExpr (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts  dsExpr (HsIf _ guard_expr then_expr else_expr)   = do { pred <- dsLExpr guard_expr@@ -476,10 +438,6 @@        ; return $ mkIfThenElse pred b1 b2 }  dsExpr (HsMultiIf res_ty alts)-  | null alts-  = mkErrorExpr--  | otherwise   = do { let grhss = GRHSs emptyComments  alts emptyLocalBinds        ; rhss_nablas  <- pmcGRHSs IfAlt grhss        ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas@@ -489,12 +447,6 @@     mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty                                (text "multi-way if") -{--\noindent-\underline{\bf Various data construction things}-             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--}- dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs  dsExpr (ArithSeq expr witness seq)@@ -503,41 +455,35 @@      Just fl -> do { newArithSeq <- dsArithSeq expr seq                    ; dsSyntaxExpr fl [newArithSeq] } -{--Static Pointers-~~~~~~~~~~~~~~~--See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.-+{- Note [Desugaring static pointers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable+for an overview.     g = ... static f ... ==>     g = ... makeStatic loc f ... -} -dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) = do-    expr_ds <- dsLExpr expr-    let (_, [ty]) = splitTyConApp whole_ty-    makeStaticId <- dsLookupGlobalId makeStaticName+dsExpr (HsStatic (_, whole_ty) expr@(L loc _))+  = do { expr_ds <- dsLExpr expr+       ; let (_, [ty]) = splitTyConApp whole_ty+       ; makeStaticId <- dsLookupGlobalId makeStaticName -    dflags <- getDynFlags-    let platform = targetPlatform dflags-    let (line, col) = case locA loc of-           RealSrcSpan r _ ->-                            ( srcLocLine $ realSrcSpanStart r-                            , srcLocCol  $ realSrcSpanStart r-                            )-           _             -> (0, 0)-        srcLoc = mkCoreTup [ mkIntExprInt platform line-                           , mkIntExprInt platform col-                           ]+       ; dflags <- getDynFlags+       ;  let platform = targetPlatform dflags+              (line, col) = case locA loc of+                  RealSrcSpan r _ -> ( srcLocLine $ realSrcSpanStart r+                                     , srcLocCol  $ realSrcSpanStart r )+                  _               -> (0, 0)+              srcLoc = mkCoreTup [ mkIntExprInt platform line+                                 , mkIntExprInt platform col+                                 ] -    putSrcSpanDsA loc $ return $-      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]+       ; putSrcSpanDsA loc $ return $+         mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] } -{--\noindent-\underline{\bf Record construction and update}-             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Desugaring record construction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For record construction we do this (assuming T has three arguments) \begin{verbatim}         T { op2 = e }@@ -560,6 +506,7 @@ dsExpr (RecordCon { rcon_con  = L _ con_like                   , rcon_flds = rbinds                   , rcon_ext  = con_expr })+-- See Note [Desugaring record construction]   = do { con_expr' <- dsExpr con_expr        ; let              (arg_tys, _) = tcSplitFunTys (exprType con_expr')@@ -577,11 +524,10 @@         ; con_args <- if null labels                      then mapM unlabelled_bottom (map scaledThing arg_tys)-                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" (map scaledThing arg_tys) labels)+                     else mapM mk_arg (zipEqual (map scaledThing arg_tys) labels)         ; return (mkCoreApps con_expr' con_args) } -dsExpr (RecordUpd x _ _) = dataConCantHappen x  -- Here is where we desugar the Template Haskell brackets and escapes @@ -596,39 +542,368 @@ -- Arrow notation extension dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd - -- HsSyn constructs that just shouldn't be here, because--- the renamer removed them.  See GHC.Rename.Expr.+-- the renamer or typechecker removed them.  See GHC.Rename.Expr. -- Note [Handling overloaded and rebindable constructs]-dsExpr (HsOverLabel x _) = dataConCantHappen x-dsExpr (OpApp x _ _ _)     = dataConCantHappen x-dsExpr (SectionL x _ _)    = dataConCantHappen x-dsExpr (SectionR x _ _)    = dataConCantHappen x+dsExpr (HsIPVar x _)      = dataConCantHappen x+dsExpr (HsGetField x _ _) = dataConCantHappen x+dsExpr (HsProjection x _) = dataConCantHappen x+dsExpr (RecordUpd x _ _)  = dataConCantHappen x+dsExpr (HsEmbTy x _)      = dataConCantHappen x+dsExpr (HsQual x _ _)     = dataConCantHappen x+dsExpr (HsForAll x _ _)   = dataConCantHappen x+dsExpr (HsFunArr x _ _ _) = dataConCantHappen x+dsExpr (HsOverLabel x _)  = dataConCantHappen x+dsExpr (OpApp x _ _ _)    = dataConCantHappen x+dsExpr (SectionL x _ _)   = dataConCantHappen x+dsExpr (SectionR x _ _)   = dataConCantHappen x -ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr-ds_prag_expr (HsPragSCC _ cc) expr = do-    dflags <- getDynFlags-    if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags-      then do-        mod_name <- getModule-        count <- goptM Opt_ProfCountEntries-        let nm = sl_fs cc-        flavour <- mkExprCCFlavour <$> getCCIndexDsM nm-        Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True)-               <$> dsLExpr expr-      else dsLExpr expr +{- *********************************************************************+*                                                                      *+*              Desugaring applications+*                                                                      *+********************************************************************* -}++{- Note [Desugaring applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we come across an application (f e1 .. en) we collect up+all the desugared arguments, and then dispatch on the function f.+(Including the nullary case where n=0.)++There are several special cases to handle++* HsRecSel: a record selector gets warnings if it might fail.+* HsVar:    special magic for `noinline`+* HsVar:    special magic for `seq`++Note [Desugaring seq]+~~~~~~~~~~~~~~~~~~~~~+There are a few subtleties in the desugaring of `seq`, all+implemented in the `seqId` case of `ds_app_var`:++ 1. (as described in #1031)++    Consider,+       f x y = x `seq` (y `seq` (# x,y #))++    Because the argument to the outer 'seq' has an unlifted type, we'll use+    call-by-value, and compile it as if we had++       f x y = case (y `seq` (# x,y #)) of v -> x `seq` v++    But that is bad, because we now evaluate y before x!++    Seq is very, very special!  So we recognise it right here, and desugar to+            case x of _ -> case y of _ -> (# x,y #)++ 2. (as described in #2273)++    Consider+       let chp = case b of { True -> fst x; False -> 0 }+       in chp `seq` ...chp...+    Here the seq is designed to plug the space leak of retaining (snd x)+    for too long.++    If we rely on the ordinary inlining of seq, we'll get+       let chp = case b of { True -> fst x; False -> 0 }+       case chp of _ { I# -> ...chp... }++    But since chp is cheap, and the case is an alluring context, we'll+    inline chp into the case scrutinee.  Now there is only one use of chp,+    so we'll inline a second copy.  Alas, we've now ruined the purpose of+    the seq, by re-introducing the space leak:+        case (case b of {True -> fst x; False -> 0}) of+          I# _ -> ...case b of {True -> fst x; False -> 0}...++    We can try to avoid doing this by ensuring that the binder-swap in the+    case happens, so we get this at an early stage:+       case chp of chp2 { I# -> ...chp2... }+    But this is fragile.  The real culprit is the source program.  Perhaps we+    should have said explicitly+       let !chp2 = chp in ...chp2...++    But that's painful.  So the code here does a little hack to make seq+    more robust: a saturated application of 'seq' is turned *directly* into+    the case expression, thus:+       x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!+       e1 `seq` e2 ==> case x of _ -> e2++    So we desugar our example to:+       let chp = case b of { True -> fst x; False -> 0 }+       case chp of chp { I# -> ...chp... }+    And now all is well.++    The reason it's a hack is because if you define mySeq=seq, the hack+    won't work on mySeq.++ 3. (as described in #2409)++    The isInternalName ensures that we don't turn+            True `seq` e+    into+            case True of True { ... }+    which stupidly tries to bind the datacon 'True'.+-}++dsApp :: HsExpr GhcTc -> DsM CoreExpr+dsApp e = ds_app e [] []++----------------------+ds_lapp :: LHsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr+-- The [LHsExpr] args correspond to the [CoreExpr] args,+-- but there may be more of the latter because they include+-- type and dictionary arguments+ds_lapp (L loc e) hs_args core_args+  = putSrcSpanDsA loc $+    ds_app e hs_args core_args++ds_app :: HsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr+-- The work-horse+ds_app (HsPar _ e) hs_args core_args = ds_lapp e hs_args core_args++ds_app (HsApp _ fun arg) hs_args core_args+  = do { core_arg <- dsLExpr arg+       ; ds_lapp fun (arg : hs_args) (core_arg : core_args) }++ds_app (HsAppType arg_ty fun _) hs_args core_args+  = ds_lapp fun hs_args (Type arg_ty : core_args)++ds_app (XExpr (WrapExpr hs_wrap fun)) hs_args core_args+  = do { (fun_wrap, all_args) <- splitHsWrapperArgs hs_wrap core_args+       ; if isIdHsWrapper fun_wrap+         then ds_app fun hs_args all_args+         else do { core_fun <- dsHsWrapper fun_wrap $ \core_wrap ->+                               do { core_fun <- dsExpr fun+                                  ; return (core_wrap core_fun) }+                 ; return (mkCoreApps core_fun all_args) } }++ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args+-- Desugar desugars 'ConLikeTc': it eta-expands+-- data constructors to make linear types work.+-- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head+  = do { ds_con <- dsHsConLike con+       ; ids    <- newSysLocalsDs tys+           -- NB: these 'Id's may be representation-polymorphic;+           -- see Wrinkle [Representation-polymorphic lambda] in+           -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head.+       ; let core_fun = mkLams tvs $ mkLams ids $+                        ds_con `mkTyApps` mkTyVarTys tvs+                               `mkVarApps` ids+       ; return (mkApps core_fun core_args) }++ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel = L _ sel_id }))) _hs_args core_args+  = ds_app_rec_sel sel_id sel_id core_args++ds_app (HsVar _ lfun) hs_args core_args+  = ds_app_var lfun hs_args core_args++ds_app e _hs_args core_args+  = do { core_e <- dsExpr e+       ; return (mkCoreApps core_e core_args) }++---------------+ds_app_var :: LocatedN Id -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr+-- Desugar an application with HsVar at the head+ds_app_var (L loc fun_id) hs_args core_args++  -----------------------+  -- Deal with getField applications. General form:+  --   getField+  --     @GHC.Types.Symbol                        {k}+  --     @"sel"                                   x_ty+  --     @T                                       r_ty+  --     @Int                                     a_ty+  --     ($dHasField :: HasField "sel" T Int)     dict+  --     :: T -> Int+  -- where+  --  $dHasField = sel |> (co :: T -> Int ~R# HasField "sel" T Int)+  -- Alas, we cannot simply look at the unfolding of $dHasField below because it+  -- has not been set yet, so we have to reconstruct the selector Id from the types.+  | fun_id `hasKey` getFieldClassOpKey+  = do {  -- Look up the field named x/"sel" in the type r/T+         fam_inst_envs <- dsGetFamInstEnvs+       ; rdr_env       <- dsGetGlobalRdrEnv+       ; let core_arg_tys :: [Type] = [ty | Type ty <- core_args]+       ; case lookupHasFieldLabel fam_inst_envs rdr_env core_arg_tys of+           Just (sel_name,_,_,_)+             -> do { sel_id <- dsLookupGlobalId sel_name+                   ; tracePm "getfield2" (ppr sel_id)+                   ; ds_app_rec_sel sel_id fun_id core_args }+           _ -> ds_app_finish fun_id core_args }++  -----------------------+  -- Warn about identities for (fromInteger :: Integer -> Integer) etc+  -- They all have a type like:  forall <tvs>. <cxt> => arg_ty -> res_ty+  | idName fun_id `elem` numericConversionNames+  , let (conv_ty, _) = apply_invis_args fun_id core_args+  , Just (arg_ty, res_ty) <- splitVisibleFunTy_maybe conv_ty+  = do { dflags <- getDynFlags+       ; when (wopt Opt_WarnIdentities dflags+               && arg_ty `eqType` res_ty)  $+         -- So we are converting  ty -> ty+         diagnosticDs (DsIdentitiesFound fun_id conv_ty)++       ; ds_app_finish fun_id core_args }++  -----------------------+  -- Warn about unused return value in+  --    do { ...; e; ... } when e returns (say) an Int+  | fun_id `hasKey` thenMClassOpKey    -- It is the built-in Prelude.(>>)+    -- (>>) :: forall m. Monad m => forall a b. m a -> (b->m b) -> m b+  , Type m_ty : _dict : Type arg_ty : _ <- core_args+  , hs_arg : _ <- hs_args+  = do { tracePm ">>" (ppr loc $$ ppr arg_ty $$ ppr (isGeneratedSrcSpan (locA loc)))+       ; when (isGeneratedSrcSpan (locA loc)) $      -- It is a compiler-generated (>>)+         warnDiscardedDoBindings hs_arg m_ty arg_ty+       ; ds_app_finish fun_id core_args }++  -----------------------+  -- Deal with `noinline`+  -- See Note [noinlineId magic] in GHC.Types.Id.Make+  | fun_id `hasKey` noinlineIdKey+  , Type _ : arg1 : rest_args <- core_args+  , (inner_fun, inner_args) <- collectArgs arg1+  = return (Var fun_id `App` Type (exprType inner_fun) `App` inner_fun+            `mkCoreApps` inner_args `mkCoreApps` rest_args)++  -----------------------+  -- Deal with `seq`+  -- See Note [Desugaring seq], points (1) and (2)+  | fun_id `hasKey` seqIdKey+  , Type _r : Type ty1 : Type ty2 : arg1 : arg2 : rest_args <- core_args+  , let case_bndr = case arg1 of+            Var v1 | isInternalName (idName v1)+                  -> v1        -- Note [Desugaring seq], points (2) and (3)+            _     -> mkWildValBinder ManyTy ty1+  = return (Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2]+            `mkCoreApps` rest_args)++  -----------------------+  -- Phew!  No more special cases.  Just build an applications+  | otherwise+  = ds_app_finish fun_id core_args++---------------+ds_app_finish :: Id -> [CoreExpr] -> DsM CoreExpr+-- We are about to construct an application that may include evidence applications+-- `f dict`.  If the dictionary is non-specialisable, instead construct+--     nospec f dict+-- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does.+-- See Note [Desugaring non-canonical evidence]+ds_app_finish fun_id core_args+  = do { mb_unspecables <- getUnspecables+       ; let fun_ty = idType fun_id+             free_dicts = exprsFreeVarsList+                            [ e | (e,pi_bndr) <- core_args `zip` fst (splitPiTys fun_ty)+                                , isInvisibleAnonPiTyBinder pi_bndr ]++             fun | Just unspecables <- mb_unspecables+                 , not (isEmptyVarSet unspecables)  -- Fast path+                 , any (`elemVarSet` unspecables) free_dicts+                 = Var nospecId `App` Type fun_ty `App` Var fun_id+                 | otherwise+                 = Var fun_id++       ; return (mkCoreApps fun core_args) }++---------------+ds_app_rec_sel :: Id             -- The record selector Id itself+               -> Id             -- The function at the the head+               -> [CoreExpr]     -- Its arguments+               -> DsM CoreExpr+-- Desugar an application with HsRecSelId at the head+ds_app_rec_sel sel_id fun_id core_args+  | RecSelId{ sel_cons = rec_sel_info } <- idDetails sel_id+  , RSI { rsi_undef = cons_wo_field } <- rec_sel_info+  = do { -- Record selectors are warned about if they are not present in all of the+         -- parent data type's constructors, or always in case of pattern synonym record+         -- selectors (regulated by a flag). However, this only produces a warning if+         -- it's not a part of a record selector application. For example:+         --         data T = T1 | T2 {s :: Bool}+         --         g y = map s y   -- Warn here+         --         f x = s x       -- No warning here+       ; let (fun_ty, val_args) = apply_invis_args fun_id core_args++       ; tracePm "ds_app_rec_sel" (ppr fun_ty $$ ppr val_args)+       ; case val_args of++           -- There is a value argument+           -- See (IRS2) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc+           (arg:_) -> pmcRecSel sel_id arg++           -- No value argument, but the selector is+           -- applied to all its type arguments+           -- See (IRS3) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc+           [] | Just (val_arg_ty, _) <- splitVisibleFunTy_maybe fun_ty+              -> do { dummy <- newSysLocalDs (Scaled ManyTy val_arg_ty)+                    ; pmcRecSel sel_id (Var dummy) }++           -- Not even applied to all its type args+           -- See (IRS4) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc+           _ -> unless (null cons_wo_field) $+                do { dflags <- getDynFlags+                   ; let maxCons = maxUncoveredPatterns dflags+                   ; diagnosticDs $ DsIncompleteRecordSelector (idName sel_id) cons_wo_field maxCons }++       ; ds_app_finish fun_id core_args }++  | otherwise+  = pprPanic "ds_app_rec_sel" (ppr sel_id $$ ppr (idDetails sel_id))+  where++apply_invis_args :: Id -> [CoreExpr] -> (Type, [CoreExpr])+-- Apply function to the initial /type/ args;+-- return the type of the instantiated function,+-- and the remaining args+--   e.g.  apply_type_args (++) [Type Int, Var xs]+--         = ([Int] -> [Int] -> [Int], [Var xs])+apply_invis_args fun_id args+  = (applyTypeToArgs fun_ty invis_args, rest_args)+  where+    fun_ty = idType fun_id+    (invis_args, rest_args) = splitAt (invisibleBndrCount fun_ty) args+ ------------------------------+splitHsWrapperArgs :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg])+-- Splits the wrapper into the trailing arguments, and leftover bit+splitHsWrapperArgs wrap args = go wrap args+  where+    go (WpTyApp ty) args = return (WpHole, Type ty : args)+    go (WpEvApp tm) args = do { core_tm <- dsEvTerm tm+                              ; return (WpHole, core_tm : args)}+    go (WpCompose w1 w2) args+      = do { (w1', args') <- go w1 args+           ; if isIdHsWrapper w1'+             then go w2 args'+             else return (w1' <.> w2, args') }+    go wrap args = return (wrap, args)++------------------------------+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+                 then mkCoreApp (text "dsConLike" <+> ppr ps)+                                (Var builder_id) unboxedUnitExpr+                 else Var builder_id) }+  | otherwise+  = pprPanic "dsConLike" (ppr ps)++------------------------------ dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsSyntaxExpr (SyntaxExprTc { syn_expr      = expr                            , syn_arg_wraps = arg_wraps                            , syn_res_wrap  = res_wrap })              arg_exprs-  = do { fun            <- dsExpr expr-       ; dsHsWrappers arg_wraps $ \core_arg_wraps -> do-       { dsHsWrapper res_wrap $ \core_res_wrap -> do-       { let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs-       ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } } }+  = do { fun <- dsExpr expr+       ; dsHsWrappers arg_wraps $ \core_arg_wraps ->+         dsHsWrapper res_wrap   $ \core_res_wrap ->+    do { let wrapped_args = zipWithEqual ($) core_arg_wraps arg_exprs+       ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } } dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"  findField :: [LHsRecField GhcTc arg] -> Name -> [arg]@@ -639,6 +914,53 @@ {- %-------------------------------------------------------------------- +Note [Desugaring non-canonical evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When constructing an application+    f @ty1 ty2 .. dict1 dict2 .. arg1 arg2 ..+if the evidence `dict_i` is canonical, we simply build that application.+But if any of the `dict_i` are /non-canonical/, we wrap the application+in `nospec`, thus+    nospec @fty f @ty1 @ty2 .. dict1 dict2 .. arg1 arg2 ..+where  nospec :: forall a. a -> a  ensures that the typeclass specialiser+doesn't attempt to common up this evidence term with other evidence terms+of the same type (see Note [nospecId magic] in GHC.Types.Id.Make).++See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv for+what a "non-canonical" dictionary is, and whe shouldn't specialise on it.++How do we decide if the arguments are non-canonical dictionaries?++* In `ds_app_finish` we look for dictionary arguments (invisible value args)++* In the DsM monad we track the "unspecables" (i.e. non-canonical dictionaries)+  in the `dsl_unspecable` field of `DsLclEnv`++* We extend that unspecable set via `addUnspecables`, in `dsEvBinds`.+  A dictionary is non-canonical if its own resolution was incoherent (see+  Note [Incoherent instances]), or if its definition refers to other non-canonical+  evidence. `dsEvBinds` is the convenient place to compute this, since it already+  needs to do inter-evidence dependency analysis to generate well-scoped+  bindings.++Wrinkle:++(NC1) We don't do this in the LHS of a RULE.  In particular, if we have+     f :: (Num a, HasCallStack) => a -> a+     {-# SPECIALISE f :: Int -> Int #-}+  then making a rule like+        RULE   forall d1:Num Int, d2:HasCallStack.+               f @Int d1 d2 = $sf+  is pretty dodgy, because $sf won't get the call stack passed in d2.+  But that's what you asked for in the SPECIALISE pragma, so we'll obey.++  We definitely can't desugar that LHS into this!+      nospec (f @Int d1) d2++  This is done by zapping the unspecables in `dsRule` to Nothing.  That `Nothing`+  says not to collect unspecables at all.++ Note [Desugaring explicit lists] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Explicit lists are desugared in a cleverer way to prevent some@@ -745,10 +1067,12 @@ -}  dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr--- SG: Surprisingly, this code path seems inactive for regular Do,+-- This code path seems inactive for regular Do, --     which is expanded in GHC.Tc.Gen.Do.---     It's all used for ApplicativeDo (even the BindStmt case), which is *very*+-- It is used only for ApplicativeDo (even the BindStmt case), which is *very* --     annoying because it is a lot of duplicated code that is seldomly tested.+-- But we are on course to expane Applicative in GHC.Tc.Gen.Do, at which+-- point all this will go away dsDo ctx stmts res_ty   = goL stmts   where@@ -761,7 +1085,9 @@      go _ (BodyStmt _ rhs then_expr _) stmts       = do { rhs2 <- dsLExpr rhs-           ; warnDiscardedDoBindings rhs (exprType rhs2)+           ; case  tcSplitAppTy_maybe (exprType rhs2) of+               Just (m_ty, elt_ty) -> warnDiscardedDoBindings rhs m_ty elt_ty+               Nothing             -> return ()  -- Odd, but not warning            ; rest <- goL stmts            ; dsSyntaxExpr then_expr [rhs2, rest] } @@ -904,49 +1230,7 @@     because we already know 'y' is of the form "Just ...".     See test case T21360b. -************************************************************************-*                                                                      *-   Desugaring Variables-*                                                                      *-************************************************************************--} -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.-dsHsVar var-  = return (varToCoreExpr var) -- See Note [Desugaring vars]--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-                 then mkCoreApp (text "dsConLike" <+> ppr ps)-                                (Var builder_id) unboxedUnitExpr-                 else Var builder_id) }-  | otherwise-  = pprPanic "dsConLike" (ppr ps)---- | This function desugars 'ConLikeTc': it eta-expands--- data constructors to make linear types work.------ See Note [Typechecking data constructors] in GHC.Tc.Gen.Head-dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr-dsConLike con tvs tys-  = do { ds_con <- dsHsConLike con-       ; ids    <- newSysLocalsDs tys-           -- NB: these 'Id's may be representation-polymorphic;-           -- see Wrinkle [Representation-polymorphic lambda] in-           -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head.-       ; return (mkLams tvs $-                 mkLams ids $-                 ds_con `mkTyApps` mkTyVarTys tvs-                        `mkVarApps` ids) }--{- ************************************************************************ *                                                                      * \subsection{Errors and contexts}@@ -955,84 +1239,30 @@ -}  -- Warn about certain types of values discarded in monadic bindings (#3263)-warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()-warnUnusedBindValue fun arg@(L loc _) arg_ty-  | Just (l, f) <- fish_var fun-  , f `hasKey` thenMClassOpKey    -- it is a (>>)-  = when (isGeneratedSrcSpan l) $ -- it is compiler generated (>>)-         putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty-  where-    -- Retrieve the location info and the head of the application-    -- It is important that we /do not/ look through HsApp to avoid-    -- generating duplicate warnings-    -- See Part 2. of Note [Expanding HsDo with XXExprGhcRn]-    fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id)-    fish_var (L l (HsVar _ id)) = return (locA l, unLoc id)-    fish_var (L _ (HsAppType _ e _)) = fish_var e-    fish_var (L l (XExpr (WrapExpr _ e))) = do (l, e') <- fish_var (L l e)-                                               return (l, e')-    fish_var (L l (XExpr (ExpandedThingTc _ e))) = fish_var (L l e)-    fish_var _ = Nothing--warnUnusedBindValue _ _ _  = return ()---- Warn about certain types of values discarded in monadic bindings (#3263)-warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()-warnDiscardedDoBindings rhs rhs_ty-  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty+warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> Type -> DsM ()+warnDiscardedDoBindings rhs m_ty elt_ty   = do { warn_unused <- woptM Opt_WarnUnusedDoBind        ; warn_wrong <- woptM Opt_WarnWrongDoBind        ; when (warn_unused || warn_wrong) $     do { fam_inst_envs <- dsGetFamInstEnvs        ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty--           -- Warn about discarding non-() things in 'monadic' binding-       ; if warn_unused && not (isUnitTy norm_elt_ty)+             supressible_ty =+               isUnitTy norm_elt_ty || isAnyTy norm_elt_ty || isZonkAnyTy norm_elt_ty+         -- Warn about discarding things in 'monadic' binding,+         -- however few types are excluded:+         --   * Unit type `()`+         --   * `ZonkAny` or `Any` type see (Any8) of Note [Any types]+       ; if warn_unused && not supressible_ty          then diagnosticDs (DsUnusedDoBind rhs elt_ty)          else             -- Warn about discarding m a things in 'monadic' binding of the same type,            -- but only if we didn't already warn due to Opt_WarnUnusedDoBind+           -- Example:   do { return 3; blah }+           -- We get   (>>) @m d @(m Int) (return 3) blah            when warn_wrong $-                case tcSplitAppTy_maybe norm_elt_ty of-                      Just (elt_m_ty, _)-                         | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty-                         -> diagnosticDs (DsWrongDoBind rhs elt_ty)-                      _ -> return () } }--  | otherwise   -- RHS does have type of form (m ty), which is weird-  = return ()   -- but at least this warning is irrelevant--{--************************************************************************-*                                                                      *-            dsHsWrapped-*                                                                      *-************************************************************************--}---------------------------------dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr-dsHsWrapped orig_hs_expr-  = go idHsWrapper orig_hs_expr-  where-    go wrap (HsPar _ (L _ hs_e))-       = go wrap hs_e-    go wrap1 (XExpr (WrapExpr wrap2 hs_e))-       = go (wrap1 <.> wrap2) hs_e-    go wrap (HsAppType ty (L _ hs_e) _)-       = go (wrap <.> WpTyApp ty) hs_e--    go wrap (HsVar _ (L _ var))-      = do { dsHsWrapper wrap $ \wrap' -> do-           { let expr = wrap' (varToCoreExpr var)-                 ty   = exprType expr-           ; dflags <- getDynFlags-           ; warnAboutIdentities dflags var ty-           ; return expr } }--    go wrap hs_e-       = do { dsHsWrapper wrap $ \wrap' -> do-            { addTyCs FromSource (hsWrapDictBinders wrap) $-              do { e <- dsExpr hs_e-                 ; return (wrap' e) } } }+           case tcSplitAppTy_maybe norm_elt_ty of+             Just (elt_m_ty, _)+                | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty+                -> diagnosticDs (DsWrongDoBind rhs elt_ty)+             _ -> return () } }
compiler/GHC/HsToCore/Foreign/Call.hs view
@@ -22,32 +22,37 @@ import GHC.Prelude  import GHC.Core--import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make-import GHC.Types.SourceText-import GHC.Types.Id.Make-import GHC.Types.ForeignCall import GHC.Core.DataCon-import GHC.HsToCore.Utils--import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Coercion-import GHC.Builtin.Types.Prim import GHC.Core.TyCon-import GHC.Builtin.Types+import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped )++import GHC.HsToCore.Monad+import GHC.HsToCore.Utils++import GHC.Types.SourceText+import GHC.Types.Id.Make+import GHC.Types.ForeignCall import GHC.Types.Basic import GHC.Types.Literal+import GHC.Types.RepType (typePrimRep1)++import GHC.Tc.Utils.TcType++import GHC.Builtin.Types.Prim+import GHC.Builtin.Types import GHC.Builtin.Names+ import GHC.Driver.DynFlags+ import GHC.Utils.Outputable import GHC.Utils.Panic  import Data.Maybe-import GHC.Types.RepType (typePrimRep1)  {- Desugaring of @ccall@s consists of adding some state manipulation,@@ -143,7 +148,7 @@     (isUnboxedTupleType arg_ty && typePrimRep1 arg_ty == VoidRep)   = return (arg, \body -> body) -  -- Recursive newtypes+  -- Possibly-recursive newtypes   | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty   = unboxArg (mkCastDs arg co) @@ -336,8 +341,10 @@   -- Data types with a single constructor, which has a single arg   -- This includes types like Ptr and ForeignPtr   | Just (tycon, tycon_arg_tys) <- maybe_tc_app-  , Just data_con <- tyConSingleAlgDataCon_maybe tycon  -- One constructor-  , null (dataConExTyCoVars data_con)                   -- no existentials+  , not (isNewTyCon tycon)  -- Newtypes should have been dealt with above, but+                            -- a recursive one might fall through here, I think+  , Just data_con <- tyConSingleDataCon_maybe tycon  -- One constructor+  , null (dataConExTyCoVars data_con)                -- no existentials   , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument   = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty        ; let marshal_con e  = Var (dataConWrapId data_con)
compiler/GHC/HsToCore/Foreign/JavaScript.hs view
@@ -265,7 +265,7 @@       (tvs,sans_foralls)            = tcSplitForAllTyVars ty       ([scaled_arg_ty], fn_res_ty)  = tcSplitFunTys sans_foralls       arg_ty                        = scaledThing scaled_arg_ty-      (io_tc, res_ty)               = expectJust "dsJsFExportDynamic: IO type expected"+      (io_tc, res_ty)               = expectJust                                         -- Must have an IO type; hence Just                                         $ tcSplitIOType_maybe fn_res_ty     mod <- getModule@@ -647,6 +647,6 @@ mkJsCall u tgt args t = mkFCall u ccall args t   where     ccall = CCall $ CCallSpec-              (StaticTarget NoSourceText tgt (Just primUnit) True)+              (StaticTarget NoSourceText tgt (Just ghcInternalUnit) True)               JavaScriptCallConv               PlayRisky
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -24,13 +24,12 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Pmc.Types ( Nablas ) import GHC.Core.Type ( Type )-import GHC.Utils.Misc import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Core.Multiplicity-import Control.Monad ( zipWithM )-import Data.List.NonEmpty ( NonEmpty, toList )+import Data.List.NonEmpty ( NonEmpty )+import qualified GHC.Data.List.NonEmpty as NE  {- @dsGuarded@ is used for GRHSs.@@ -62,9 +61,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) $-                          zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss+  = do { match_results <- assert (length grhss == length rhss_nablas) $+                          NE.zipWithM (dsGRHS hs_ctx rhs_ty) rhss_nablas grhss        ; nablas <- getPmNablas        -- We need to remember the Nablas from the particular match context we        -- are in, which might be different to when dsLocalBinds is actually
compiler/GHC/HsToCore/ListComp.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies   #-}  {-@@ -36,6 +36,8 @@ import GHC.Tc.Utils.TcType import GHC.Data.List.SetOps( getNth ) +import Data.Foldable ( toList )+ {- List comprehensions may be desugared in one of two ways: ``ordinary'' (as you would expect if you read SLPJ's book) and ``with foldr/build@@ -243,13 +245,13 @@   = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs        ; let (exps, qual_tys) = unzip exps_and_qual_tys -       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys+       ; (zip_fn, zip_rhs) <- mkZipBind (toList qual_tys)          -- Deal with [e | pat <- zip l1 .. ln] in example above-       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))+       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) (toList exps)))                     quals list }   where-        bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]+        bndrs_s = [bs | ParStmtBlock _ _ bs _ <- toList stmtss_w_bndrs]          -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above         pat  = mkBigLHsPatTupId pats@@ -563,8 +565,11 @@  = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)        ; mzip_op'    <- dsExpr mzip_op -       ; let -- The pattern variables-             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]+       ; let parStmtBlockIds :: ParStmtBlock GhcTc GhcTc -> [Id]+             parStmtBlockIds = \ case+                 ParStmtBlock _ _ bs _ -> bs+             -- The pattern variables+             pats = fmap (mkBigLHsVarPatTupId . parStmtBlockIds) blocks              -- Pattern with tuples of variables              -- [v1,v2,v3]  =>  (v1, (v2, v3))              pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
compiler/GHC/HsToCore/Match.hs view
@@ -77,7 +77,7 @@ import GHC.Types.Unique.DFM  import Control.Monad ( zipWithM, unless )-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map @@ -194,9 +194,7 @@       -> [EquationInfo]   -- ^ Info about patterns, etc. (type synonym below)       -> DsM (MatchResult CoreExpr) -- ^ Desugared result! -match [] ty eqns-  = assertPpr (not (null eqns)) (ppr ty) $-    combineEqnRhss (NE.fromList eqns)+match [] ty eqns = maybe (assertPprPanic (ppr ty)) combineEqnRhss $ nonEmpty eqns  match (v:vs) ty eqns    -- Eqns can be empty, but each equation is nonempty   = assertPpr (all (isInternalName . idName) vars) (ppr vars) $@@ -303,7 +301,7 @@          -- compile the view expressions         ; viewExpr' <- dsExpr viewExpr         ; return (mkViewMatchResult var'-                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))+                    (mkCoreApp (text "matchView") viewExpr' (Var var))                     match_result) }  -- decompose the first pattern and leave the rest alone@@ -529,7 +527,7 @@     mk_match lpat body = noLocA $ Match noExtField CaseAlt (noLocA [lpat]) (single_grhs body)      hs_var :: Var -> LHsExpr GhcTc-    hs_var v = (noLocA $ HsVar noExtField (noLocA v))+    hs_var v = noLocA $ mkHsVar (noLocA v)     single_grhs :: LHsExpr GhcTc -> GRHSs GhcTc (LHsExpr GhcTc)     single_grhs e = GRHSs emptyComments [noLocA $ GRHS noAnn [] e] (EmptyLocalBinds noExtField) @@ -599,9 +597,9 @@                            -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc -- 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))+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))   = assert (null args) $-    PrefixCon ts [L l (BangPat noExtField arg)]+    PrefixCon [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf)   | HsRecFields { rec_flds = L lf fld : flds } <- rf   , HsFieldBind { hfbRHS = arg } <- fld@@ -610,7 +608,7 @@                                            = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})   | HsRecFields { rec_flds = [] } <- rf-  = PrefixCon [] [L l (BangPat noExtField (noLocA (WildPat ty)))]+  = PrefixCon [L l (BangPat noExtField (noLocA (WildPat ty)))] push_bang_into_newtype_arg _ _ cd   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -801,7 +799,7 @@         ; new_vars    <- case matches of                            []    -> newSysLocalsDs arg_tys                            (m:_) ->-                            selectMatchVars (zipWithEqual "matchWrapper"+                            selectMatchVars (zipWithEqual                                               (\a b -> (scaledMult a, unLoc b))                                                 arg_tys                                                 (hsLMatchPats m))@@ -859,10 +857,7 @@       = map (\(L _ m) -> (ldi_nablas, initNablasGRHSs ldi_nablas (m_grhss m))) ms      initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas-    initNablasGRHSs ldi_nablas m-      = expectJust "GRHSs non-empty"-      $ NE.nonEmpty-      $ replicate (length (grhssGRHSs m)) ldi_nablas+    initNablasGRHSs ldi_nablas m = ldi_nablas <$ grhssGRHSs m  {- Note [Long-distance information in matchWrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1225,7 +1220,7 @@                           , syn_arg_wraps = arg_wraps2                           , syn_res_wrap  = res_wrap2 })       = exp expr1 expr2 &&-        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&+        and (zipWithEqual wrap arg_wraps1 arg_wraps2) &&         wrap res_wrap1 res_wrap2     syn_exp NoSyntaxExprTc NoSyntaxExprTc = True     syn_exp _              _              = False
compiler/GHC/HsToCore/Match/Constructor.hs view
@@ -182,7 +182,7 @@         -- Divide into sub-groups; see Note [Record patterns]         ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfoNE))               groups = NE.groupBy1 compatible_pats-                     $ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)+                     $ fmap (\eqn -> (con_pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)          ; match_results <- mapM (match_group arg_vars) groups @@ -191,6 +191,10 @@                               alt_wrapper = wrapper1,                               alt_result = foldr1 combineMatchResults match_results } }   where+    con_pat_args :: Pat GhcTc -> HsConPatDetails GhcTc+    con_pat_args (ConPat { pat_args = args }) = args+    con_pat_args p = pprPanic "matchOneConLike" (ppr p)  -- All patterns are ConPats+     ConPat { pat_con = L _ con1            , pat_args = args1            , pat_con_ext = ConPatTc@@ -217,7 +221,7 @@       | otherwise       = arg_vars       where-        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars+        fld_var_env = mkNameEnv $ zipEqual fields1 arg_vars         lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env                                             (idName (hsRecFieldId rpat)) @@ -243,17 +247,17 @@ selectConMatchVars arg_tys con   = case con of       RecCon {}      -> newSysLocalsDs arg_tys-      PrefixCon _ ps -> selectMatchVars (zipMults arg_tys ps)+      PrefixCon ps   -> selectMatchVars (zipMults arg_tys ps)       InfixCon p1 p2 -> selectMatchVars (zipMults arg_tys [p1, p2])   where-    zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b))+    zipMults = zipWithEqual (\a b -> (scaledMult a, unLoc b))  conArgPats :: [Scaled Type]-- Instantiated argument types                           -- Used only to fill in the types of WildPats, which                           -- are probably never looked at anyway            -> ConArgPats            -> [LPat GhcTc]-conArgPats _arg_tys (PrefixCon _ ps) = ps+conArgPats _arg_tys (PrefixCon ps) = ps conArgPats _arg_tys (InfixCon p1 p2) = [p1, p2] conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))   | null rpats = map (noLocA . WildPat . scaledThing) arg_tys
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -18,7 +18,7 @@    ( dsLit, dsOverLit, hsLitKey    , tidyLitPat, tidyNPat    , matchLiterals, matchNPlusKPats, matchNPats-   , warnAboutIdentities+   , numericConversionNames    , warnAboutOverflowedOverLit, warnAboutOverflowedLit    , warnAboutEmptyEnumerations    )@@ -61,16 +61,15 @@ import GHC.Driver.DynFlags  import GHC.Utils.Outputable as Outputable-import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Unique (sameUnique)  import GHC.Data.FastString+import qualified GHC.Data.List.NonEmpty as NEL  import Control.Monad import Data.Int import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NEL import Data.Word import GHC.Real ( Ratio(..), numerator, denominator ) @@ -97,7 +96,7 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. -} -dsLit :: HsLit GhcRn -> DsM CoreExpr+dsLit :: forall p. IsPass p => HsLit (GhcPass p) -> DsM CoreExpr dsLit l = do   dflags <- getDynFlags   let platform = targetPlatform dflags@@ -122,9 +121,11 @@     HsChar _ c       -> return (mkCharExpr c)     HsString _ str   -> mkStringExprFS str     HsMultilineString _ str -> mkStringExprFS str-    HsInteger _ i _  -> return (mkIntegerExpr platform i)     HsInt _ i        -> return (mkIntExpr platform (il_value i))-    HsRat _ fl ty    -> dsFractionalLitToRational fl ty+    XLit x           -> case ghcPass @p of+      GhcTc          -> case x of+        HsInteger _ i _  -> return (mkIntegerExpr platform i)+        HsRat fl ty      -> dsFractionalLitToRational fl ty  {- Note [FractionalLit representation]@@ -275,23 +276,13 @@ same.  Then it's probably (albeit not definitely) the identity -} -warnAboutIdentities :: DynFlags -> Id -> Type -> DsM ()-warnAboutIdentities dflags conv_fn type_of_conv-  | wopt Opt_WarnIdentities dflags-  , idName conv_fn `elem` conversionNames-  , Just (_, _, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv-  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty-  = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv)-warnAboutIdentities _ _ _ = return ()--conversionNames :: [Name]-conversionNames+numericConversionNames :: [Name]+numericConversionNames   = [ toIntegerName, toRationalName     , fromIntegralName, realToFracName ]  -- We can't easily add fromIntegerName, fromRationalName,  -- because they are generated by literals - -- | Emit warnings on overloaded integral literals which overflow the bounds -- implied by their type. warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()@@ -460,24 +451,24 @@ -- | If 'Integral', extract the value and type of the non-overloaded literal. getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type) getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy)-getSimpleIntegralLit (HsIntPrim _ i)    = Just (i, intPrimTy)-getSimpleIntegralLit (HsWordPrim _ i)   = Just (i, wordPrimTy)-getSimpleIntegralLit (HsInt8Prim _ i)   = Just (i, int8PrimTy)-getSimpleIntegralLit (HsInt16Prim _ i)  = Just (i, int16PrimTy)-getSimpleIntegralLit (HsInt32Prim _ i)  = Just (i, int32PrimTy)-getSimpleIntegralLit (HsInt64Prim _ i)  = Just (i, int64PrimTy)-getSimpleIntegralLit (HsWord8Prim _ i)  = Just (i, word8PrimTy)-getSimpleIntegralLit (HsWord16Prim _ i) = Just (i, word16PrimTy)-getSimpleIntegralLit (HsWord32Prim _ i) = Just (i, word32PrimTy)-getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy)-getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty)+getSimpleIntegralLit (HsIntPrim _ i)            = Just (i, intPrimTy)+getSimpleIntegralLit (HsWordPrim _ i)           = Just (i, wordPrimTy)+getSimpleIntegralLit (HsInt8Prim _ i)           = Just (i, int8PrimTy)+getSimpleIntegralLit (HsInt16Prim _ i)          = Just (i, int16PrimTy)+getSimpleIntegralLit (HsInt32Prim _ i)          = Just (i, int32PrimTy)+getSimpleIntegralLit (HsInt64Prim _ i)          = Just (i, int64PrimTy)+getSimpleIntegralLit (HsWord8Prim _ i)          = Just (i, word8PrimTy)+getSimpleIntegralLit (HsWord16Prim _ i)         = Just (i, word16PrimTy)+getSimpleIntegralLit (HsWord32Prim _ i)         = Just (i, word32PrimTy)+getSimpleIntegralLit (HsWord64Prim _ i)         = Just (i, word64PrimTy)+getSimpleIntegralLit (XLit (HsInteger _ i ty))  = Just (i, ty)  getSimpleIntegralLit HsChar{}           = Nothing getSimpleIntegralLit HsCharPrim{}       = Nothing getSimpleIntegralLit HsString{}         = Nothing getSimpleIntegralLit HsMultilineString{} = Nothing getSimpleIntegralLit HsStringPrim{}     = Nothing-getSimpleIntegralLit HsRat{}            = Nothing+getSimpleIntegralLit (XLit (HsRat{}))   = Nothing getSimpleIntegralLit HsFloatPrim{}      = Nothing getSimpleIntegralLit HsDoublePrim{}     = Nothing @@ -721,8 +712,8 @@         ; lit2_expr   <- dsOverLit lit2         ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]         ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]-        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)-        ; match_result <- match vars ty eqns'+        ; let (wraps, eqns') = NEL.mapAndUnzip (shift n1) (eqn1:|eqns)+        ; match_result <- match vars ty (NEL.toList eqns')         ; return  (mkGuardedMatchResult pred_expr               $                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $                    fmap (foldr1 (.) wraps)                      $
compiler/GHC/HsToCore/Monad.hs view
@@ -26,7 +26,7 @@         mkNamePprCtxDs,         newUnique,         UniqSupply, newUniqueSupply,-        getGhcModeDs, dsGetFamInstEnvs,+        getGhcModeDs, dsGetFamInstEnvs, dsGetGlobalRdrEnv,         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,         dsLookupDataCon, dsLookupConLike,         getCCIndexDsM,@@ -37,7 +37,7 @@         getPmNablas, updPmNablas,          -- Tracking evidence variable coherence-        addUnspecables, getUnspecables,+        addUnspecables, getUnspecables, zapUnspecables,          -- Get COMPLETE sets of a TyCon         dsGetCompleteMatches,@@ -45,7 +45,6 @@         -- Warnings and errors         DsWarning, diagnosticDs, errDsCoreExpr,         failWithDs, failDs, discardWarningsDs,-        addMessagesDs, captureMessagesDs,          -- Data types         DsMatchContext(..),@@ -95,7 +94,8 @@ import GHC.Types.Name.Reader import GHC.Types.SourceFile import GHC.Types.Id-import GHC.Types.Var (EvId)+import GHC.Types.Var (EvVar)+import GHC.Types.Var.Set( VarSet, emptyVarSet, extendVarSetList ) import GHC.Types.SrcLoc import GHC.Types.TypeEnv import GHC.Types.Unique.Supply@@ -118,7 +118,6 @@  import Data.IORef import GHC.Driver.Env.KnotVars-import qualified Data.Set as S import GHC.IO.Unsafe (unsafeInterleaveIO)  {-@@ -157,6 +156,7 @@  type EquationInfoNE = EquationInfo -- An EquationInfo which has at least one pattern+--   i.e. it's an EqnMatch, not EqnDone  prependPats :: [LPat GhcTc] -> EquationInfo -> EquationInfo prependPats [] eqn = eqn@@ -266,17 +266,20 @@              ptc = initPromotionTickContext (hsc_dflags hsc_env)              -- re-use existing next_wrapper_num to ensure uniqueness              next_wrapper_num_var = tcg_next_wrapper_num tcg_env+             tcg_comp_env = tcg_complete_match_env tcg_env         ; ds_complete_matches <-            liftIO $ unsafeInterleaveIO $+             -- Note [Lazily loading COMPLETE pragmas]+             -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~              -- This call to 'unsafeInterleaveIO' ensures we only do this work              -- when we need to look at the COMPLETE pragmas, avoiding doing work              -- when we don't need them.              --              -- Relevant test case: MultiLayerModulesTH_Make, which regresses              -- in allocations by ~5% if we don't do this.-           traverse (lookupCompleteMatch type_env hsc_env) $-             localAndImportedCompleteMatches (tcg_complete_matches tcg_env) hsc_env eps+           traverse (lookupCompleteMatch type_env hsc_env) =<<+             localAndImportedCompleteMatches tcg_comp_env eps        ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc                            msg_var cc_st_var next_wrapper_num_var ds_complete_matches        }@@ -333,8 +336,8 @@              bindsToIds (NonRec v _)   = [v]              bindsToIds (Rec    binds) = map fst binds              ids = concatMap bindsToIds binds-       ; ds_complete_matches <- traverse (lookupCompleteMatch type_env hsc_env) $-            localAndImportedCompleteMatches local_complete_matches hsc_env eps+       ; ds_complete_matches <- traverse (lookupCompleteMatch type_env hsc_env) =<<+            localAndImportedCompleteMatches local_complete_matches eps        ; let              envs  = mkDsEnvs unit_env this_mod rdr_env type_env                               fam_inst_env ptc msg_var cc_st_var@@ -406,7 +409,7 @@         lcl_env = DsLclEnv { dsl_meta        = emptyNameEnv                            , dsl_loc         = real_span                            , dsl_nablas      = initNablas-                           , dsl_unspecables = mempty+                           , dsl_unspecables = Just emptyVarSet                            }     in (gbl_env, lcl_env) @@ -469,10 +472,17 @@ updPmNablas :: Nablas -> DsM a -> DsM a updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas }) -addUnspecables :: S.Set EvId -> DsM a -> DsM a-addUnspecables unspecables = updLclEnv (\env -> env{ dsl_unspecables = unspecables `mappend` dsl_unspecables env })+addUnspecables :: [EvVar] -> DsM a -> DsM a+addUnspecables new_unspecables+  = updLclEnv (\env -> case dsl_unspecables env of+                          Nothing -> env+                          Just us -> env { dsl_unspecables+                                             = Just (us `extendVarSetList` new_unspecables) }) -getUnspecables :: DsM (S.Set EvId)+zapUnspecables :: DsM a -> DsM a+zapUnspecables = updLclEnv (\env -> env{ dsl_unspecables = Nothing })++getUnspecables :: DsM (Maybe VarSet) getUnspecables = dsl_unspecables <$> getLclEnv  getSrcSpanDs :: DsM SrcSpan@@ -499,12 +509,6 @@        ; let msg = mkMsgEnvelope diag_opts loc (ds_name_ppr_ctx env) dsMessage        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -addMessagesDs :: Messages DsMessage -> DsM ()-addMessagesDs msgs1-  = do { msg_var <- ds_msgs <$> getGblEnv-       ; msgs0 <- liftIO $ readIORef msg_var-       ; liftIO $ writeIORef msg_var (msgs0 `unionMessages` msgs1) }- -- | Issue an error, but return the expression for (), so that we can continue -- reporting errors. errDsCoreExpr :: DsMessage -> DsM CoreExpr@@ -520,13 +524,6 @@ failDs :: DsM a failDs = failM -captureMessagesDs :: DsM a -> DsM (Messages DsMessage, a)-captureMessagesDs thing_inside-  = do { msg_var <- liftIO $ newIORef emptyMessages-       ; res <- updGblEnv (\gbl -> gbl {ds_msgs = msg_var}) thing_inside-       ; msgs <- liftIO $ readIORef msg_var-       ; return (msgs, res) }- mkNamePprCtxDs :: DsM NamePprCtx mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv @@ -566,6 +563,9 @@  dsGetMetaEnv :: DsM (NameEnv DsMetaVal) dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }++dsGetGlobalRdrEnv :: DsM GlobalRdrEnv+dsGetGlobalRdrEnv = ds_gbl_rdr_env <$> getGblEnv  -- | The @COMPLETE@ pragmas that are in scope. dsGetCompleteMatches :: DsM DsCompleteMatches
compiler/GHC/HsToCore/Pmc.hs view
@@ -133,7 +133,7 @@   -> DsM (NonEmpty Nablas)        -- ^ Covered 'Nablas' for each RHS, for long                                   --   distance info pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do-  let combined_loc = foldl1 combineSrcSpans (map getLocA grhss)+  let combined_loc = foldl1 combineSrcSpans (NE.map getLocA grhss)       ctxt = DsMatchContext hs_ctxt combined_loc   !missing <- getLdiNablas   matches  <- noCheckDs $ desugarGRHSs combined_loc empty guards@@ -201,85 +201,197 @@ {- Note [Detecting incomplete record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A record selector occurrence is incomplete iff. it could fail due to-being applied to a data type constructor not present for this record field.+This Note describes the implementation of+GHC proposal 516 "Add warning for incomplete record selectors". -e.g.-  data T = T1 | T2 {x :: Int}-  d = x someComputation -- `d` may fail+A **partial field** is a field that does not belong to every constructor of the+corresponding datatype.+A **partial selector occurrence** is a use of a record selector for a partial+field, either as a selector function in an expression, or as the solution to a+HasField constraint. -There are 4 parts to detecting and warning about-incomplete record selectors to consider:+Partial selector occurrences desugar to case expressions which may crash at+runtime: -  - Computing which constructors a general application of a record field will succeed on,-    and which ones it will fail on. This is stored in the `sel_cons` field of-    `IdDetails` datatype, which is a part of an `Id` and calculated when renaming a-    record selector in `mkOneRecordSelector`+  data T a where+    T1 :: T Int+    T2 {sel :: Int} :: T Bool -  - Emitting a warning whenever a `HasField` constraint is solved.-    This is checked in `matchHasField` and emitted only for when-    the constraint is resolved with an implicit instance rather than a-    custom one (since otherwise the warning will be emitted in-      the custom implementation anyways)+  urgh :: T a -> Int+  urgh x = sel x+  ===>+  urgh x = case x of+    T1 -> error "no record field sel"+    T2 f -> f -    e.g.-      g :: HasField "x" t Int => t -> Int-      g = getField @"x"+As such, it makes sense to warn about such potential crashes.+We do so whenever -Wincomplete-record-selectors is present, and we utilise+the pattern-match coverage checker for precise results, because there are many+uses of selectors for partial fields which are in fact dynamically safe. -      f :: T -> Int-      f = g -- warning will be emitted here+Pmc can detect two very common safe uses for which we will not warn: -  - Emitting a warning for a general occurrence of the record selector-    This is done during the renaming of a `HsRecSel` expression in `dsExpr`-    and simply pulls the information about incompleteness from the `Id`+ (LDI) Ambient pattern-matches unleash Note [Long-distance information] that+       render a naively flagged partial selector occurrence safe, as in+         ldi :: T a -> Int+         ldi T1  = 0+         ldi arg = sel arg+       We should not warn here, because `arg` cannot be `T1`. -    e.g.-      l :: T -> Int-      l a = x a -- warning will be emitted here+ (RES) Constraining the result type of a GADT such as T might render+       naively flagged partial selector occurrences safe, as in+         resTy :: T Bool -> Int+         resTy = sel+       Here, `T1 :: T Int` is ruled out because it has the wrong result type. -  - Emitting a warning for a record selector `sel` applied to a variable `y`.-    In that case we want to use the long-distance information from the-    pattern match checker to rule out impossible constructors-    (See Note [Long-distance information]). We first add constraints to-    the long-distance `Nablas` that `y` cannot be one of the constructors that-    contain `sel` (function `checkRecSel` in GHC.HsToCore.Pmc.Check). If the-    `Nablas` are still inhabited, we emit a warning with the inhabiting constructors-    as examples of where `sel` may fail.+Additionally, we want to support incomplete -XOverloadedRecordDot access as+well, in either the (LDI) use case or the (RES) use case: -    e.g.-      z :: T -> Int-      z T1 = 0-      z a = x a -- warning will not be emitted here since `a` can only be `T2`+  data Dot = No | Yes { sel2 :: Int }+  dot d = d.sel2      -- should warn+  ldiDot No = 0+  ldiDot d  = d.sel2  -- should not warn+  resTyDot :: T Bool -> Int+  resTyDot x = x.sel  -- should not warn++From a user's point of view, function `ldiDot` looks very like example `ldi` and+`resTyDot` looks very like `resTy`. But from an /implementation/ point of view+they are very different: both `ldiDot` and `resTyDot` simply emit `HasField`+constraints, and it is those constraints that the implementation must use to+determine incompleteness.++Furthermore, HasField constraints allow to delay the completeness check from+the field access site to a caller, as in test cases TcIncompleteRecSel and T24891:++  accessDot :: HasField "sel2" t Int => t -> Int+  accessDot x = x.sel2   -- getField @Symbol @"sel2" @t @Int x+  solveDot :: Dot -> Int+  solveDot = accessDot++We should warn in `solveDot`, but not in `accessDot`.++Here is how we achieve all this in the implementation:++(IRS1) When renaming a record selector in `mkOneRecordSelector`,+    we precompute the constructors the selector succeeds on.+    That would be `T2` for `sel` because `sel (T2 42)` succeeds,+    and `Yes` for `sel2` because `sel2 (Yes 13)` succeeds.+    We store this information in the `sel_cons` field of `RecSelId`.+    (Remember, the same field may occur in several constructors of the data+    type; hence the selector may succeed on more than one constructor.)++We generate warnings for incomplete record selectors in two places:+* Mainly: in GHC.HsToCore.Expr.ds_app (see (IRS2-5) below)+* Plus: in GHC.Tc.Instance.Class.matchHassField (see (IRS6-7) below)++(IRS2) In function `ldi`, we have a record selector application `sel arg`.+    This situation is detected `GHC.HsToCore.Expr.ds_app_rec_sel`, when the+    record selector is applied to at least one argument. We call out to the+    pattern-match checker to determine whether use of the selector is safe,+    by calling GHC.HsToCore.Pmc.pmcRecSel, passing the `RecSelId` `sel` as+    well as `arg`.++    The pattern-match checker reduces the partial-selector-occurrence problem to+    a complete-match problem by adding a negative constructor constraint such as+    `arg /~ T2` for every constructor in the precomputed `rsi_def . sel_cons` of+    `sel`. (Recall that these were exactly the constructors which define a field+    `sel`.) `pmcRecSel` then tests+      case arg of {}+    for completeness. Any incomplete match, such as in the original `urgh`, must+    reference a constructor that does not have field `sel`, such as `T1`.++    In case of `urgh`, `T1` is indeed the case that we report as inexhaustive.++    However, in function `ldi`, we have *both* the result type of+    `arg::T a` (boring, but see (IRS3)) as well as Note [Long-distance information]+    about `arg` from the ambient match, and the latter lists the constraint+    `arg /~ T1`. Consequently, since `arg` is neither `T1` nor `T2` in the+    reduced problem, the match is exhaustive and the use of the record selector+    safe.++(IRS3) In function `resTy`, the record selector is unsaturated, but the result type+    ensures a safe use of the selector.++    This situation is also detected in `GHC.HsToCore.Expr.ds_app_rec_sel`.+    THe selector is elaborated with its type arguments; we simply match on+    desugared Core `sel @Bool :: T Bool -> Int` to learn the result type `T Bool`.+    We again call `pmcRecSel`, but this time with a fresh dummy Id `ds::T Bool`.++(IRS4) In case of an unsaturated record selector that is *not* applied to any type+  argument after elaboration (e.g. in `urgh2 = sel2 :: Dot -> Int`), we simply+  produce a warning about all `sel_cons`; no need to call `pmcRecSel`.+  This happens in `ds_app_rec_sel`++Finally, there are two more items addressing -XOverloadedRecordDot:++(IRS5) With -XOverloadedDot, all occurrences of (r.x), such as in `ldiDot` and+  `accessDot` above, are warned about as follows.  `r.x` is parsed as+  `HsGetField` in `HsExpr`; which is then expanded (in `rnExpr`) to a call to+  `getField`.  For example, consider:+         ldiDot No = 0+         ldiDot x  = x.sel2  -- should not warn+  The `d.sel2` in the RHS generates+      getField @GHC.Types.Symbol @"sel2" @Dot @Int+               ($dHasField :: HasField "sel2" Dot Int) x+  where+      $dHasField = sel2 |> (co :: Dot -> Int ~R# HasField "sel2" Dot Int)+  We spot this `getField` application in `GHC.HsToCore.Expr.ds_app_var`,+  and treat it exactly like (IRS2) and (IRS3).++  Note carefully that doing this in the desugarer allows us to account for the+  long-distance info about `x`; even though `sel2` is partial, we don't want+  to warn about `x.sel2` in this example.++(IRS6) Finally we have+          solveDot :: Dot -> Int+          solveDot = accessDot+  No field-accesses or selectors in sight!  From the RHS we get the constraint+      [W] HasField @"sel2" @Dot @Int`+  The only time we can generate a warning is when we solve this constraint,+  in `GHC.Tc.Instance.Class.matchHasField`, generating a call to the (partial)+  selector.  We have no hope of exploiting long-distance info here.++(IRS7) BUT, look back at `ldiDot`.  Doesn't `matchHasField` /also/ generate a+  warning for the `HasField` constraint arising from `x.sel2`?  We don't+  want that, because the desugarer will catch it: see (IRS5).  So we suppress+  the (IRS6) warning in the typechecker for a `HasField` constraint that+  arises from a record-dot HsGetField occurrence.  Happily, this is easy to do+  by looking at its `CtOrigin`. Tested in T24891. -}  pmcRecSel :: Id       -- ^ Id of the selector           -> CoreExpr -- ^ Core expression of the argument to the selector           -> DsM ()+-- See (IRS2,3) in Note [Detecting incomplete record selectors] pmcRecSel sel_id arg-  | RecSelId{ sel_cons = (cons_w_field, _ : _) } <- idDetails sel_id = do-      !missing <- getLdiNablas+  | RecSelId{ sel_cons = rec_sel_info } <- idDetails sel_id+  , RSI { rsi_def = cons_w_field, rsi_undef = cons_wo_field } <- rec_sel_info+  , not (null cons_wo_field)+  = do { !missing <- getLdiNablas -      tracePm "pmcRecSel {" (ppr sel_id)-      CheckResult{ cr_ret = PmRecSel{ pr_arg_var = arg_id }, cr_uncov = uncov_nablas }-        <- unCA (checkRecSel (PmRecSel () arg cons_w_field)) missing-      tracePm "}: " $ ppr uncov_nablas+       ; tracePm "pmcRecSel {" (ppr sel_id)+       ; CheckResult{ cr_ret = PmRecSel{ pr_arg_var = arg_id }, cr_uncov = uncov_nablas }+           <- unCA (checkRecSel (PmRecSel () arg cons_w_field)) missing+       ; tracePm "}: " $ ppr uncov_nablas -      inhabited <- isInhabited uncov_nablas-      when inhabited $ warn_incomplete arg_id uncov_nablas-        where-          sel_name = varName sel_id-          warn_incomplete arg_id uncov_nablas = do-            dflags <- getDynFlags-            let maxConstructors = maxUncoveredPatterns dflags-            unc_examples <- getNFirstUncovered MinimalCover [arg_id] (maxConstructors + 1) uncov_nablas-            let cons = [con | unc_example <- unc_examples-                      , Just (PACA (PmAltConLike con) _ _) <- [lookupSolution unc_example arg_id]]-                not_full_examples = length cons == (maxConstructors + 1)-                cons' = take maxConstructors cons-            diagnosticDs $ DsIncompleteRecordSelector sel_name cons' not_full_examples+       ; inhabited <- isInhabited uncov_nablas+       ; when inhabited $ warn_incomplete arg_id uncov_nablas } -pmcRecSel _ _ = return ()+  | otherwise+  = return () +  where+     sel_name = varName sel_id+     warn_incomplete arg_id uncov_nablas = do+       dflags <- getDynFlags+       let maxPatterns = maxUncoveredPatterns dflags+       unc_examples <- getNFirstUncovered MinimalCover [arg_id] (maxPatterns + 1) uncov_nablas+       let cons = [con | unc_example <- unc_examples+                 , Just (PACA (PmAltConLike con) _ _) <- [lookupSolution unc_example arg_id]]+       tracePm "unc-ex" (ppr cons $$ ppr unc_examples)+       diagnosticDs $ DsIncompleteRecordSelector sel_name cons maxPatterns++ {- Note [pmcPatBind doesn't warn on pattern guards] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @pmcPatBind@'s main purpose is to check vanilla pattern bindings, like@@ -512,8 +624,8 @@  -- | Locally update 'dsl_nablas' with the given action, but defer evaluation -- with 'unsafeInterleaveM' in order not to do unnecessary work.-locallyExtendPmNablas :: (Nablas -> DsM Nablas) -> DsM a -> DsM a-locallyExtendPmNablas ext k = do+locallyExtendPmNablas :: DsM a -> (Nablas -> DsM Nablas) -> DsM a+locallyExtendPmNablas k ext = do   nablas <- getLdiNablas   nablas' <- unsafeInterleaveM $ ext nablas   updPmNablas nablas' k@@ -521,12 +633,15 @@ -- | Add in-scope type constraints if the coverage checker might run and then -- run the given action. addTyCs :: Origin -> Bag EvVar -> DsM a -> DsM a-addTyCs origin ev_vars m = do-  dflags <- getDynFlags-  applyWhen (needToRunPmCheck dflags origin)-            (locallyExtendPmNablas $ \nablas ->-              addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars))-            m+addTyCs origin ev_vars thing_inside+  | isEmptyBag ev_vars+  = thing_inside  -- Very common fast path+  | otherwise+  = do { dflags <- getDynFlags+       ; if needToRunPmCheck dflags origin+         then locallyExtendPmNablas thing_inside $ \nablas ->+              addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars)+         else thing_inside }  -- | Add equalities for the 'CoreExpr' scrutinees to the local 'DsM' environment, -- e.g. when checking a case expression:@@ -537,8 +652,8 @@ -- to be added for multiple scrutinees rather than just one. addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a addCoreScrutTmCs []         _      k = k-addCoreScrutTmCs (scr:scrs) (x:xs) k =-  flip locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas ->+addCoreScrutTmCs (scr:scrs) (x:xs) k+  = locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas ->     addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr)) addCoreScrutTmCs _   _   _ = panic "addCoreScrutTmCs: numbers of scrutinees and match ids differ" 
compiler/GHC/HsToCore/Pmc/Desugar.hs view
@@ -37,7 +37,7 @@ import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper) import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)-import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar, decideBangHood, checkMultiplicityCoercions)+import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar, decideBangHood) import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad import GHC.Core.TyCo.Rep@@ -48,7 +48,6 @@ import Control.Monad (zipWithM, replicateM) import Data.List (elemIndex) import Data.List.NonEmpty ( NonEmpty(..) )-import qualified Data.List.NonEmpty as NE  -- import GHC.Driver.Ppr @@ -220,13 +219,13 @@           Just l -> l           Nothing -> pprPanic "failed to detect OverLit" (ppr olit)     let lit' = case mb_neg of-          Just _  -> expectJust "failed to negate lit" (negatePmLit lit)+          Just _  -> expectJust (negatePmLit lit)           Nothing -> lit     mkPmLitGrds x lit'    LitPat _ lit -> do-    core_expr <- dsLit (convertLit lit)-    let lit = expectJust "failed to detect Lit" (coreExprAsPmLit core_expr)+    core_expr <- dsLit lit+    let lit = expectJust (coreExprAsPmLit core_expr)     mkPmLitGrds x lit    TuplePat _tys pats boxity -> do@@ -271,11 +270,9 @@ desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]                  -> [EvVar] -> HsConPatDetails GhcTc -> DsM GrdDag desugarConPatOut x con univ_tys ex_tvs dicts = \case-    PrefixCon _ ps               -> go_field_pats (zip [0..] ps)-    InfixCon  p1 p2              -> go_field_pats (zip [0..] [p1,p2])-    RecCon    (HsRecFields mult_cos fs _) -> do-      checkMultiplicityCoercions mult_cos-      go_field_pats (rec_field_ps fs)+    PrefixCon ps                            -> go_field_pats (zip [0..] ps)+    InfixCon  p1 p2                         -> go_field_pats (zip [0..] [p1,p2])+    RecCon    (HsRecFields NoExtField fs _) -> go_field_pats (rec_field_ps fs)   where     -- The actual argument types (instantiated)     arg_tys     = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs)@@ -288,7 +285,7 @@         -- 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-        lbl_to_index lbl = expectJust "lbl_to_index" $ elemIndex lbl orig_lbls+        lbl_to_index lbl = expectJust $ elemIndex lbl orig_lbls      go_field_pats tagged_pats = do       -- The fields that appear might not be in the correct order. So@@ -346,10 +343,7 @@ desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre) desugarGRHSs match_loc pp_pats grhss = do   lcls <- desugarLocalBinds (grhssLocalBinds grhss)-  grhss' <- traverse (desugarLGRHS match_loc pp_pats)-              . expectJust "desugarGRHSs"-              . NE.nonEmpty-              $ grhssGRHSs grhss+  grhss' <- traverse (desugarLGRHS match_loc pp_pats) (grhssGRHSs grhss)   return PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss' }  -- | Desugar a guarded right-hand side to a single 'GrdTree'@@ -394,7 +388,7 @@       -- See Note [Long-distance information for HsLocalBinds] for why this       -- pattern match is so very specific.       | L _ [L _ Match{m_pats = L _ [], m_grhss = grhss}] <- mg_alts mg-      , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do+      , GRHSs{grhssGRHSs = L _ (GRHS _ _grds rhs) :| []} <- grhss = do           core_rhs <- dsLExpr rhs           return (GdOne (PmLet x core_rhs))     go (L _ (XHsBindsLR (AbsBinds
compiler/GHC/HsToCore/Pmc/Solver.hs view
@@ -64,7 +64,7 @@ import GHC.Core.FVs         (exprFreeVars) import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Map.Expr-import GHC.Core.Predicate (typeDeterminesValue)+import GHC.Core.Predicate (typeDeterminesValue, mkNomEqPred) import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils     (exprType) import GHC.Core.Make      (mkListExpr, mkCharExpr, mkImpossibleExpr)@@ -95,7 +95,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict import Data.Coerce-import Data.Foldable (foldlM, minimumBy, toList)+import Data.Foldable (foldlM, toList) import Data.Monoid   (Any(..)) import Data.List     (sortBy, find) import qualified Data.List.NonEmpty as NE@@ -363,7 +363,7 @@     eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)      is_closed_or_data_family :: Type -> Bool-    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty+    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyApp ty      -- For efficiency, represent both lists as difference lists.     -- comb performs the concatenation, for both lists.@@ -679,7 +679,7 @@  filterUnliftedFields :: PmAltCon -> [Id] -> [Id] filterUnliftedFields con args =-  [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con)+  [ arg | (arg, bang) <- zipEqual args (pmAltConImplBangs con)         , isBanged bang || definitelyUnliftedType (idType arg) ]  -- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@@@ -786,7 +786,7 @@       let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs)       nabla' <- MaybeT $ addPhiCts nabla (listToBag ty_cts)       let add_var_ct nabla (a, b) = addVarCt nabla a b-      foldlM add_var_ct nabla' $ zipEqual "addConCt" args other_args+      foldlM add_var_ct nabla' $ zipEqual args other_args     Nothing -> do       let pos' = PACA alt tvs args : pos       let nabla_with bot' =@@ -803,8 +803,8 @@  equateTys :: [Type] -> [Type] -> [PhiCt] equateTys ts us =-  [ PhiTyCt (mkPrimEqPred t u)-  | (t, u) <- zipEqual "equateTys" ts us+  [ PhiTyCt (mkNomEqPred t u)+  | (t, u) <- zipEqual ts us   -- The following line filters out trivial Refl constraints, so that we don't   -- need to initialise the type oracle that often   , not (eqType t u)
compiler/GHC/HsToCore/Quote.hs view
@@ -12,8 +12,6 @@ {-# LANGUAGE TypeFamilies           #-} {-# LANGUAGE UndecidableInstances   #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2006@@ -48,6 +46,7 @@  import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence+import GHC.Tc.TyCl ( IsPrefixConGADT(..), unannotatedMultIsLinear )  import GHC.Core.Class import GHC.Core.DataCon@@ -71,6 +70,7 @@  import GHC.Data.FastString import GHC.Data.Maybe+import qualified GHC.Data.List.NonEmpty as NE  import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique@@ -98,7 +98,7 @@ import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class-import GHC.Types.Name.Reader (RdrName(..))+import GHC.Types.Name.Reader (RdrName(..), WithUserRdr (..))  data MetaWrappers = MetaWrappers {       -- Applies its argument to a type argument `m` and dictionary `Quote m`@@ -120,15 +120,15 @@       -- to be used to construct the monadWrapper.       quote_tc <- dsLookupTyCon quoteClassName       monad_tc <- dsLookupTyCon monadClassName-      let Just cls = tyConClass_maybe quote_tc-          Just monad_cls = tyConClass_maybe monad_tc+      let cls = expectJust $ tyConClass_maybe quote_tc+          monad_cls = expectJust $ tyConClass_maybe monad_tc           -- Quote m -> Monad m           monad_sel = classSCSelId cls 0            -- Only used for the defensive assertion that the selector has           -- the expected type           tyvars = dataConUserTyVarBinders (classDataCon cls)-          expected_ty = mkInvisForAllTys tyvars $+          expected_ty = mkForAllTys tyvars $                         mkFunTy invisArgConstraintLike ManyTy                                 (mkClassPred cls (mkTyVarTys (binderVars tyvars)))                                 (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))@@ -176,7 +176,7 @@       DecBrG _ gp -> runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }       DecBrL {}   -> panic "dsUntypedBracket: unexpected DecBrL"   where-    Just wrap = mb_wrap  -- Not used in VarBr case+    wrap = expectJust mb_wrap  -- Not used in VarBr case       -- In the overloaded case we have to get given a wrapper, it is just       -- the VarBr case that there is no wrapper, because they       -- have a simple type.@@ -800,29 +800,37 @@ repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repRuleD (L loc (HsRule { rd_name = n                         , rd_act = act-                        , rd_tyvs = m_ty_bndrs-                        , rd_tmvs = tm_bndrs+                        , rd_bndrs = bndrs                         , rd_lhs = lhs                         , rd_rhs = rhs }))+  = fmap (locA loc, ) <$>+      repRuleBinders bndrs $ \ ty_bndrs' tm_bndrs' ->+        do { n'   <- coreStringLit $ unLoc n+           ; act' <- repPhases act+           ; lhs' <- repLE lhs+           ; rhs' <- repLE rhs+           ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }++repRuleBinders :: RuleBndrs GhcRn+               -> (Core (Maybe [M (TH.TyVarBndr ())]) -> Core [M TH.RuleBndr] -> MetaM (Core (M a)))+               -> MetaM (Core (M a))+repRuleBinders (RuleBndrs { rb_tyvs = m_ty_bndrs, rb_tmvs = tm_bndrs }) thing_inside   = do { let ty_bndrs = fromMaybe [] m_ty_bndrs-       ; rule <- addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs ->-         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs-            ; ss <- mkGenSyms tm_bndr_names-            ; rule <- addBinds ss $-                      do { elt_ty <- wrapName tyVarBndrUnitTyConName-                         ; ty_bndrs' <- return $ case m_ty_bndrs of-                             Nothing -> coreNothing' (mkListTy elt_ty)-                             Just _  -> coreJust' (mkListTy elt_ty) ex_bndrs-                         ; tm_bndrs' <- repListM ruleBndrTyConName-                                                repRuleBndr-                                                tm_bndrs-                         ; n'   <- coreStringLit $ unLoc n-                         ; act' <- repPhases act-                         ; lhs' <- repLE lhs-                         ; rhs' <- repLE rhs-                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }-           ; wrapGenSyms ss rule  }-       ; return (locA loc, rule) }+       ; addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs ->+          do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs+             ; ss <- mkGenSyms tm_bndr_names+             ; x <- addBinds ss $+                 do { elt_ty <- wrapName tyVarBndrUnitTyConName+                    ; ty_bndrs' <- return $ case m_ty_bndrs of+                        Nothing -> coreNothing' (mkListTy elt_ty)+                        Just _  -> coreJust' (mkListTy elt_ty) ex_bndrs+                    ; tm_bndrs' <- repListM ruleBndrTyConName+                                           repRuleBndr+                                           tm_bndrs+                    ; thing_inside ty_bndrs' tm_bndrs'+                    }+              ; wrapGenSyms ss x }+        }  ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]@@ -883,29 +891,46 @@               else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])             } -repC (L _ (ConDeclGADT { con_names  = cons-                       , con_bndrs  = L _ outer_bndrs+repC (L l (ConDeclGADT { con_names  = cons+                       , con_outer_bndrs = L _ outer_bndrs+                       , con_inner_bndrs = inner_bndrs                        , con_mb_cxt = mcxt                        , con_g_args = args                        , con_res_ty = res_ty }))-  | null_outer_imp_tvs && null_outer_exp_tvs-                                 -- No implicit or explicit variables-  , Nothing <- mcxt              -- No context-                                 -- ==> no need for a forall-  = repGadtDataCons cons args res_ty+  | no_explicit_forall, no_context+  -- No explicit variables, no context  ==>  No need for a ForallC+  -- See Note [Don't quantify implicit type variables in quotes]+  = addSimpleTyVarBinds FreshNamesOnly (hsOuterTyVarNames outer_bndrs) $+    repGadtDataCons cons args res_ty -  | otherwise+  | Just invis_inner_bndrs <- m_invis_inner_bndrs   = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' ->-             -- See Note [Don't quantify implicit type variables in quotes]-    do { c'    <- repGadtDataCons cons args res_ty-       ; ctxt' <- repMbContext mcxt-       ; if null_outer_exp_tvs && isNothing mcxt-         then return c'-         else rep2 forallCName ([unC outer_bndrs', unC ctxt', unC c']) }+    -- the context is attached to the innermost ForallC+    let loop last_bndrs' [] = do+          ctxt' <- repMbContext mcxt+          c'    <- repGadtDataCons cons args res_ty+          rep2 forallCName ([unC last_bndrs', unC ctxt', unC c'])+        loop last_bndrs' (bndrs : bndrs_s) =+          addHsTyVarBinds FreshNamesOnly bndrs $ \bndrs' -> do+            body_c' <- loop bndrs' bndrs_s+            ctxt' <- repContext []+            rep2 forallCName [unC last_bndrs', unC ctxt', unC body_c']+    in loop outer_bndrs' invis_inner_bndrs++  | Nothing <- m_invis_inner_bndrs+  = notHandledL (locA l) ThDataConVisibleForall+   where-    null_outer_imp_tvs = nullOuterImplicit outer_bndrs-    null_outer_exp_tvs = nullOuterExplicit outer_bndrs+    no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_bndrs+    no_context         = isNothing mcxt +    m_invis_inner_bndrs :: Maybe [[LHsTyVarBndr Specificity GhcRn]]+    m_invis_inner_bndrs = traverse get_invis_bndrs inner_bndrs++    get_invis_bndrs :: HsForAllTelescope GhcRn -> Maybe [LHsTyVarBndr Specificity GhcRn]+    get_invis_bndrs HsForAllVis{} = Nothing+    get_invis_bndrs HsForAllInvis { hsf_invis_bndrs = tvbs } = Just tvbs+ repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) repMbContext Nothing          = repContext [] repMbContext (Just (L _ cxt)) = repContext cxt@@ -920,17 +945,13 @@ repSrcStrictness SrcStrict   = rep2 sourceStrictName       [] repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] -repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))-repBangTy ty = do-  MkC u <- repSrcUnpackedness su'-  MkC s <- repSrcStrictness ss'+repConDeclField :: HsConDeclField GhcRn -> MetaM (Core (M TH.BangType))+repConDeclField (CDF { cdf_unpack, cdf_bang, cdf_type }) = do+  MkC u <- repSrcUnpackedness cdf_unpack+  MkC s <- repSrcStrictness cdf_bang   MkC b <- rep2 bangName [u, s]-  MkC t <- repLTy ty'+  MkC t <- repLTy cdf_type   rep2 bangTypeName [b, t]-  where-    (su', ss', ty') = case unLoc ty of-            HsBangTy _ (HsBang su ss) ty -> (su, ss, ty)-            _ -> (NoSrcUnpack, NoSrcStrict, ty)  ------------------------------------------------------- --                      Deriving clauses@@ -993,8 +1014,11 @@ rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc) rep_sig (L loc (SpecSig _ nm tys ispec))   = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys-rep_sig (L loc (SpecInstSig _ ty))  = rep_specialiseInst ty (locA loc)-rep_sig (L _   (MinimalSig {}))       = notHandled ThMinimalPragmas+rep_sig (L loc (SpecSigE _nm bndrs expr ispec))+  = fmap (\ d -> [(locA loc, d)]) $+    rep_specialiseE bndrs expr ispec+rep_sig (L loc (SpecInstSig _ ty))   = rep_specialiseInst ty (locA loc)+rep_sig (L _   (MinimalSig {}))      = notHandled ThMinimalPragmas rep_sig (L loc (SCCFunSig _ nm str)) = rep_sccFun nm str (locA loc) rep_sig (L loc (CompleteMatchSig _ cls mty))   = rep_complete_sig cls mty (locA loc)@@ -1095,23 +1119,38 @@        ; return [(loc, pragma)]        } +rep_inline_phases :: InlinePragma -> MetaM (Maybe (Core TH.Inline), Core TH.Phases)+rep_inline_phases (InlinePragma { inl_act = act, inl_inline = inl })+  = do { phases <- repPhases act+       ; inl <- if noUserInlineSpec inl+                -- SPECIALISE+                then return Nothing+                -- SPECIALISE INLINE+                else Just <$> repInline inl+       ; return (inl, phases) }+ rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma                -> SrcSpan                -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_specialise nm ty ispec loc+  -- Old form SPECIALISE pragmas   = do { nm1 <- lookupLOcc nm        ; ty1 <- repHsSigType ty-       ; phases <- repPhases $ inl_act ispec-       ; let inline = inl_inline ispec-       ; pragma <- if noUserInlineSpec inline-                   then -- SPECIALISE-                     repPragSpec nm1 ty1 phases-                   else -- SPECIALISE INLINE-                     do { inline1 <- repInline inline-                        ; repPragSpecInl nm1 ty1 inline1 phases }+       ; (inl, phases) <- rep_inline_phases ispec+       ; pragma <- repPragSpec nm1 ty1 inl phases        ; return [(loc, pragma)]        } +rep_specialiseE :: RuleBndrs GhcRn -> LHsExpr GhcRn -> InlinePragma+                -> MetaM (Core (M TH.Dec))+rep_specialiseE bndrs e ispec+  -- New form SPECIALISE pragmas+  = repRuleBinders bndrs $ \ ty_bndrs tm_bndrs ->+      do { (inl, phases) <- rep_inline_phases ispec+         ; exp <- repLE e+         ; repPragSpecE ty_bndrs tm_bndrs exp inl phases+         }+ rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan                    -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_specialiseInst ty loc@@ -1228,17 +1267,6 @@   HsOuterExplicit{hso_bndrs = exp_bndrs} ->     addHsTyVarBinds FreshNamesOnly exp_bndrs thing_inside --- | If a type implicitly quantifies its outermost type variables, return--- 'True' if the list of implicitly bound type variables is empty. If a type--- explicitly quantifies its outermost type variables, always return 'True'.------ This is used in various places to determine if a Template Haskell 'Type'--- should be headed by a 'ForallT' or not.-nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool-nullOuterImplicit (HsOuterImplicit{hso_ximplicit = imp_tvs}) = null imp_tvs-nullOuterImplicit (HsOuterExplicit{})                        = True-  -- Vacuously true, as there is no implicit quantification- -- | If a type explicitly quantifies its outermost type variables, return -- 'True' if the list of explicitly bound type variables is empty. If a type -- implicitly quantifies its outermost type variables, always return 'True'.@@ -1402,7 +1430,7 @@          repTForallVis bndrs body1 repTy ty@(HsQualTy {}) = repForallT ty -repTy (HsTyVar _ _ (L _ n))+repTy (HsTyVar _ _ (L _ (WithUserRdr _ n)))   | n `hasKey` liftedTypeKindTyConKey  = repTStar   | n `hasKey` constraintKindTyConKey  = repTConstraint   | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon@@ -1427,16 +1455,17 @@                                 ty1 <- repLTy ty                                 ki1 <- repLTy ki                                 repTappKind ty1 ki1-repTy (HsFunTy _ w f a) | isUnrestricted w = do-                                f1   <- repLTy f-                                a1   <- repLTy a+repTy (HsFunTy _ w f a) = do+                            f1   <- repLTy f+                            a1   <- repLTy a+                            case multAnnToHsType w of+                              Nothing -> do                                 tcon <- repArrowTyCon                                 repTapps tcon [f1, a1]-repTy (HsFunTy _ w f a) = do w1   <- repLTy (arrowToHsType w)-                             f1   <- repLTy f-                             a1   <- repLTy a-                             tcon <- repMulArrowTyCon-                             repTapps tcon [w1, f1, a1]+                              Just m -> do+                                w1 <- repLTy m+                                tcon <- repMulArrowTyCon+                                repTapps tcon [w1, f1, a1] repTy (HsListTy _ t)        = do                                 t1   <- repLTy t                                 tcon <- repListTyCon@@ -1451,7 +1480,7 @@ repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys                                  tcon <- repUnboxedSumTyCon (length tys)                                  repTapps tcon tys1-repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (unLoc n) `nlHsAppTy` ty1)+repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (getName n) `nlHsAppTy` ty1)                                    `nlHsAppTy` ty2) repTy (HsParTy _ t)         = repLTy t repTy (HsStarTy _ _) =  repTStar@@ -1533,7 +1562,7 @@ repLE (L loc e) = mapReaderT (putSrcSpanDs (locA loc)) (repE e)  repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp))-repE (HsVar _ (L _ x)) =+repE (HsVar _ (L _ (WithUserRdr _ x))) =   do { mb_val <- lift $ dsLookupMetaEnv x      ; case mb_val of         Nothing            -> do { str <- lift $ globalVar x@@ -1541,6 +1570,10 @@         Just (DsBound y)   -> repVarOrCon x (coreVar y)         Just (DsSplice e)  -> do { e' <- lift $ dsExpr e                                  ; return (MkC e') } }+repE (HsHole (HoleVar (L _ uv))) = do+  name <- repRdrName uv+  repUnboundVar name+repE (HsHole HoleError) = panic "repE: HoleError" repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar repE (HsOverLabel _ s) = repOverLabel s @@ -1587,8 +1620,8 @@                             c <- repLE z                             repCond a b c repE (HsMultiIf _ alts)-  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts-       ; expr' <- repMultiIf (nonEmptyCoreList alts')+  = do { (binds, alts') <- NE.unzip <$> mapM repLGRHS alts+       ; expr' <- repMultiIf (nonEmptyCoreList' alts')        ; wrapGenSyms (concat binds) expr' } repE (HsLet _ bs e)       = do { (ss,ds) <- repBinds bs                                ; e2 <- addBinds ss (repLE e)@@ -1637,7 +1670,7 @@       ; repUnboxedSum e1 alt arity }  repE (RecordCon { rcon_con = c, rcon_flds = flds })- = do { x <- lookupLOcc c;+ = do { x <- lookupWithUserRdrLOcc c;         fs <- repFields flds;         repRecCon x fs } repE (RecordUpd { rupd_expr = e, rupd_flds = RegularRecUpdFields { recUpdFields = flds } })@@ -1675,13 +1708,11 @@                              ds3 <- repLE e3                              repFromThenTo ds1 ds2 ds3 -repE (HsTypedSplice n _) = rep_splice n+repE (HsTypedSplice (HsTypedSpliceNested n) _) = rep_splice n repE (HsUntypedSplice (HsUntypedSpliceNested n) _)  = rep_splice n repE e@(HsUntypedSplice (HsUntypedSpliceTop _ _) _) = pprPanic "repE: top level splice" (ppr e)+repE e@(HsTypedSplice HsTypedSpliceTop _) = pprPanic "repE: top level splice" (ppr e) repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC-repE (HsUnboundVar _ uv)   = do-                               name <- repRdrName uv-                               repUnboundVar name repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do   e1 <- repLE e   repGetField e1 f@@ -1704,7 +1735,7 @@         body' <- repLE body         rep2 forall_name [unC bndrs, unC body'] repE (HsFunArr _ mult arg res) = do-  fun  <- repFunArr mult+  fun  <- repFunArrMult mult   arg' <- repLE arg   res' <- repLE res   repApps fun [arg', res']@@ -1718,19 +1749,19 @@   = notHandled (ThExpressionForm e)  repE (XExpr (PopErrCtxt (L _ e))) = repE e-repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (HsVar noExtField (noLocA x))+repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (mkHsVar (noLocA x))  repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e) repE e@(HsTypedBracket{})   = notHandled (ThExpressionForm e) repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e) repE e@(HsProc{}) = notHandled (ThExpressionForm e) -repFunArr :: HsArrowOf (LocatedA (HsExpr GhcRn)) GhcRn -> MetaM (Core (M TH.Exp))-repFunArr HsUnrestrictedArrow{} = repConName unrestrictedFunTyConName-repFunArr mult-  = do { fun <- repConName fUNTyConName-       ; mult' <- repLE (arrowToHsExpr mult)-       ; repApp fun mult' }+repFunArrMult :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> MetaM (Core (M TH.Exp))+repFunArrMult mult = case multAnnToHsExpr mult of+  Nothing -> repConName unrestrictedFunTyConName+  Just e -> do { fun <- repConName fUNTyConName+               ; mult' <- repLE e+               ; repApp fun mult' }  repConName :: Name -> MetaM (Core (M TH.Exp)) repConName n = do@@ -1788,13 +1819,13 @@      ; clause <- repClause ps1 gs ds      ; wrapGenSyms (ss1++ss2) clause }}} -repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  MetaM (Core (M TH.Body))-repGuards [L _ (GRHS _ [] e)]+repGuards :: NonEmpty (LGRHS GhcRn (LHsExpr GhcRn)) ->  MetaM (Core (M TH.Body))+repGuards (L _ (GRHS _ [] e) :| [])   = do {a <- repLE e; repNormal a } repGuards other   = do { zs <- mapM repLGRHS other-       ; let (xs, ys) = unzip zs-       ; gd <- repGuarded (nonEmptyCoreList ys)+       ; let (xs, ys) = NE.unzip zs+       ; gd <- repGuarded (nonEmptyCoreList' ys)        ; wrapGenSyms (concat xs) gd }  repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)@@ -1887,8 +1918,8 @@       ; (ss2,zs) <- repSts ss       ; return (ss2, z : zs) } repSts (ParStmt _ stmt_blocks _ _ : ss) =-   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks-      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1+   do { (ss_s, stmt_blocks1) <- unzip <$> traverse rep_stmt_block stmt_blocks+      ; let stmt_blocks2 = nonEmptyCoreList' stmt_blocks1             ss1 = concat ss_s       ; z <- repParSt stmt_blocks2       ; (ss2, zs) <- addBinds ss1 (repSts ss)@@ -2033,7 +2064,7 @@     -- their pattern-only bound right hand sides have different names,     -- we want to treat them the same in TH. This is the reason why we     -- need an adjusted mkGenArgSyms in the `RecCon` case below.-    mkGenArgSyms (PrefixCon _ args)   = mkGenSyms (map unLoc args)+    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)     mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]     mkGenArgSyms (RecCon fields)       = do { let pats = map (unLoc . recordPatSynPatVar) fields@@ -2061,7 +2092,7 @@   = rep2 patSynDName [syn, args, dir, pat]  repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs))-repPatSynArgs (PrefixCon _ args)+repPatSynArgs (PrefixCon args)   = do { args' <- repList nameTyConName lookupLOcc args        ; repPrefixPatSynArgs args' } repPatSynArgs (InfixCon arg1 arg2)@@ -2120,7 +2151,7 @@  repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) repLambda (L _ (Match { m_pats = L _ ps-                      , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]+                      , m_grhss = GRHSs _ (L _ (GRHS _ [] e) :| [])                                               (EmptyLocalBinds _) } ))  = do { let bndrs = collectPatsBinders CollNoDictBinders ps ;       ; ss  <- mkGenSyms bndrs@@ -2164,12 +2195,11 @@ repP (SumPat _ p alt arity) = do { p1 <- repLP p                                  ; repPunboxedSum p1 alt arity } repP (ConPat NoExtField dc details)- = do { con_str <- lookupLOcc dc+ = do { con_str <- lookupWithUserRdrLOcc dc       ; case details of-         PrefixCon tyargs ps -> do { qs <- repLPs ps-                                   ; let unwrapTyArg (HsConPatTyArg _ t) = unLoc (hstp_body t)-                                   ; ts <- repListM typeTyConName (repTy . unwrapTyArg) tyargs-                                   ; repPcon con_str ts qs }+         PrefixCon ps -> do { ts' <- repListM typeTyConName (repTy . unLoc . hstp_body) (takeHsConPatTyArgs ps)+                            ; ps' <- repLPs (dropHsConPatTyArgs ps)+                            ; repPcon con_str ts' ps' }          RecCon rec   -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)                             ; repPrec con_str fps }          InfixCon p1 p2 -> do { p1' <- repLP p1;@@ -2267,6 +2297,9 @@ -- Use the in-scope bindings if they exist lookupLOcc n = lookupOcc (unLoc n) +lookupWithUserRdrLOcc :: GenLocated l (WithUserRdr Name) -> MetaM (Core TH.Name)+lookupWithUserRdrLOcc (L _loc (WithUserRdr _rdr n)) = lookupOcc n+ lookupOcc :: Name -> MetaM (Core TH.Name) lookupOcc = lift . lookupOccDsM @@ -2749,15 +2782,26 @@ repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec)) repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm] -repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases+repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Maybe (Core (TH.Inline))+            -> Core TH.Phases             -> MetaM (Core (M TH.Dec))-repPragSpec (MkC nm) (MkC ty) (MkC phases)-  = rep2 pragSpecDName [nm, ty, phases]+repPragSpec (MkC nm) (MkC ty) mb_inl (MkC phases)+  = case mb_inl of+      Nothing ->+        rep2 pragSpecDName [nm, ty, phases]+      Just (MkC inl) ->+        rep2 pragSpecInlDName [nm, ty, inl, phases] -repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline-               -> Core TH.Phases -> MetaM (Core (M TH.Dec))-repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)-  = rep2 pragSpecInlDName [nm, ty, inline, phases]+repPragSpecE :: Core (Maybe [M (TH.TyVarBndr ())]) -> Core [(M TH.RuleBndr)]+             -> Core (M TH.Exp)+             -> Maybe (Core TH.Inline) -> Core TH.Phases+             -> MetaM (Core (M TH.Dec))+repPragSpecE (MkC ty_bndrs) (MkC tm_bndrs) (MkC expr) mb_inl (MkC phases)+  = case mb_inl of+      Nothing ->+        rep2 pragSpecEDName    [ty_bndrs, tm_bndrs, expr, phases]+      Just (MkC inl) ->+        rep2 pragSpecInlEDName [ty_bndrs, tm_bndrs, expr, inl, phases]  repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec)) repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]@@ -2832,13 +2876,13 @@ repH98DataCon con details     = do con' <- lookupLOcc con -- See Note [Binders and occurrences]          case details of-           PrefixCon _ ps -> do-             arg_tys <- repPrefixConArgs ps+           PrefixCon ps -> do+             arg_tys <- repPrefixConArgs IsNotPrefixConGADT ps              rep2 normalCName [unC con', unC arg_tys]            InfixCon st1 st2 -> do-             verifyLinearFields [st1, st2]-             arg1 <- repBangTy (hsScaledThing st1)-             arg2 <- repBangTy (hsScaledThing st2)+             verifyLinearFields IsNotPrefixConGADT [st1, st2]+             arg1 <- repConDeclField st1+             arg2 <- repConDeclField st2              rep2 infixCName [unC arg1, unC con', unC arg2]            RecCon ips -> do              arg_vtys <- repRecConArgs ips@@ -2852,7 +2896,7 @@     = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]          case details of            PrefixConGADT _ ps -> do-             arg_tys <- repPrefixConArgs ps+             arg_tys <- repPrefixConArgs IsPrefixConGADT ps              res_ty' <- repLTy res_ty              rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty']            RecConGADT _ ips -> do@@ -2864,36 +2908,37 @@ -- TH currently only supports linear constructors. -- We also accept the (->) arrow when -XLinearTypes is off, because this -- denotes a linear field.--- This check is not performed in repRecConArgs, since the GADT record--- syntax currently does not have a way to mark fields as nonlinear.-verifyLinearFields :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()-verifyLinearFields ps = do-  linear <- lift $ xoptM LangExt.LinearTypes-  let allGood = all (\st -> case hsMult st of-                              HsUnrestrictedArrow _ -> not linear-                              HsLinearArrow _       -> True-                              _                     -> False) ps+verifyLinearFields :: IsPrefixConGADT -> [HsConDeclField GhcRn] -> MetaM ()+verifyLinearFields isPrefixConGADT ps = do+  linear <- lift $ unannotatedMultIsLinear isPrefixConGADT+  let allGood = all (hsMultIsLinear linear . cdf_multiplicity) ps   unless allGood $ notHandled ThNonLinearDataCon+  where+    hsMultIsLinear linear HsUnannotated{} = linear+    hsMultIsLinear _ HsLinearAnn{} = True+    hsMultIsLinear _ (HsExplicitMult _ (L _ (HsTyVar _ _ (L _ n)))) = getName n == oneDataConName+    hsMultIsLinear _ _ = False  -- Desugar the arguments in a data constructor declared with prefix syntax.-repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]-                 -> MetaM (Core [M TH.BangType])-repPrefixConArgs ps = do-  verifyLinearFields ps-  repListM bangTypeTyConName repBangTy (map hsScaledThing ps)+repPrefixConArgs :: IsPrefixConGADT -> [HsConDeclField GhcRn] -> MetaM (Core [M TH.BangType])+repPrefixConArgs isPrefixConGADT ps = do+  verifyLinearFields isPrefixConGADT ps+  repListM bangTypeTyConName repConDeclField ps  -- Desugar the arguments in a data constructor declared with record syntax.-repRecConArgs :: LocatedL [LConDeclField GhcRn]+repRecConArgs :: LocatedL [LHsConDeclRecField GhcRn]               -> MetaM (Core [M TH.VarBangType])-repRecConArgs ips = do-  args     <- concatMapM rep_ip (unLoc ips)+repRecConArgs lips = do+  let ips = map unLoc (unLoc lips)+  verifyLinearFields IsNotPrefixConGADT (map cdrf_spec ips)+  args <- concatMapM rep_ip ips   coreListM varBangTypeTyConName args     where-      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)+      rep_ip ip = mapM (rep_one_ip (cdrf_spec ip)) (cdrf_names ip) -      rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))+      rep_one_ip :: HsConDeclField GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))       rep_one_ip t n = do { MkC v  <- lookupOcc (unLoc . foLabel $ unLoc n)-                          ; MkC ty <- repBangTy  t+                          ; MkC ty <- repConDeclField t                           ; rep2 varBangTypeName [v,ty] }  ------------ Types -------------------@@ -3010,7 +3055,7 @@ ---------------------------------------------------------- --              Literals -repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)+repLiteral ::  HsLit GhcRn -> MetaM (Core TH.Lit) repLiteral (HsStringPrim _ bs)   = do word8_ty <- lookupType word8TyConName        let w8s = unpack bs@@ -3019,20 +3064,19 @@        rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] repLiteral lit   = do lit' <- case lit of-                   HsIntPrim _ i    -> mk_integer i-                   HsWordPrim _ w   -> mk_integer w-                   HsInt _ i        -> mk_integer (il_value i)-                   HsFloatPrim _ r  -> mk_rational r-                   HsDoublePrim _ r -> mk_rational r-                   HsCharPrim _ c   -> mk_char c-                   _ -> return lit-       lit_expr <- lift $ dsLit lit'+                   HsIntPrim _ i    -> lift . dsLit <$> mk_integer i+                   HsWordPrim _ w   -> lift . dsLit <$> mk_integer w+                   HsInt _ i        -> lift . dsLit <$> mk_integer (il_value i)+                   HsFloatPrim _ r  -> lift . dsLit <$> mk_rational r+                   HsDoublePrim _ r -> lift . dsLit <$> mk_rational r+                   HsCharPrim _ c   -> lift . dsLit <$> mk_char c+                   _                -> return . lift . dsLit $ lit+       lit_expr <- lit'        case mb_lit_name of           Just lit_name -> rep2_nw lit_name [lit_expr]           Nothing -> notHandled (ThExoticLiteral lit)   where     mb_lit_name = case lit of-                 HsInteger _ _ _  -> Just integerLName                  HsInt _ _        -> Just integerLName                  HsIntPrim _ _    -> Just intPrimLName                  HsWordPrim _ _   -> Just wordPrimLName@@ -3042,15 +3086,15 @@                  HsCharPrim _ _   -> Just charPrimLName                  HsString _ _     -> Just stringLName                  HsMultilineString _ _ -> Just stringLName-                 HsRat _ _ _      -> Just rationalLName                  _                -> Nothing -mk_integer :: Integer -> MetaM (HsLit GhcRn)-mk_integer  i = return $ HsInteger NoSourceText i integerTy+mk_integer :: Integer -> MetaM (HsLit GhcTc)+mk_integer  i = return $ XLit $ HsInteger NoSourceText i integerTy -mk_rational :: FractionalLit -> MetaM (HsLit GhcRn)+mk_rational :: FractionalLit -> MetaM (HsLit GhcTc) mk_rational r = do rat_ty <- lookupType rationalTyConName-                   return $ HsRat noExtField r rat_ty+                   return $ XLit $ HsRat r rat_ty+ mk_string :: FastString -> MetaM (HsLit GhcRn) mk_string s = return $ HsString NoSourceText s @@ -3059,15 +3103,25 @@  repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val})-  = do { lit <- mk_lit val; repLiteral lit }-        -- The type Rational will be in the environment, because-        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,-        -- and rationalL is sucked in when any TH stuff is used+  = repOverLiteralVal val+    -- The type Rational will be in the environment, because+    -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,+    -- and rationalL is sucked in when any TH stuff is used -mk_lit :: OverLitVal -> MetaM (HsLit GhcRn)-mk_lit (HsIntegral i)     = mk_integer  (il_value i)-mk_lit (HsFractional f)   = mk_rational f-mk_lit (HsIsString _ s)   = mk_string   s+repOverLiteralVal ::  OverLitVal -> MetaM (Core TH.Lit)+repOverLiteralVal lit = do+  lit' <- case lit of+        (HsIntegral i)   -> lift . dsLit <$> mk_integer  (il_value i)+        (HsFractional f) -> lift . dsLit <$> mk_rational f+        (HsIsString _ s) -> lift . dsLit <$> mk_string   s+  lit_expr <- lit'++  let lit_name = case lit of+        (HsIntegral _  ) -> integerLName+        (HsFractional _) -> rationalLName+        (HsIsString _ _) -> stringLName++  rep2_nw lit_name [lit_expr]  repRdrName :: RdrName -> MetaM (Core TH.Name) repRdrName rdr_name = do
− compiler/GHC/HsToCore/Ticks.hs 
@@ -1,1283 +0,0 @@-{-# LANGUAGE DeriveFunctor            #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TypeFamilies             #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--{--(c) Galois, 2006-(c) University of Glasgow, 2007--}--module GHC.HsToCore.Ticks-  ( TicksConfig (..)-  , Tick (..)-  , TickishType (..)-  , addTicksToBinds-  , isGoodSrcSpan'-  , stripTicksTopHsExpr-  ) where--import GHC.Prelude as Prelude--import GHC.Hs-import GHC.Unit--import GHC.Core.Type-import GHC.Core.TyCon--import GHC.Data.Maybe-import GHC.Data.FastString-import GHC.Data.SizedSeq--import GHC.Driver.Flags (DumpFlag(..))--import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Utils.Logger-import GHC.Types.SrcLoc-import GHC.Types.Basic-import GHC.Types.Id-import GHC.Types.Var.Set-import GHC.Types.Name.Set hiding (FreeVars)-import GHC.Types.Name-import GHC.Types.CostCentre-import GHC.Types.CostCentre.State-import GHC.Types.Tickish-import GHC.Types.ProfAuto--import Control.Monad-import Data.List (isSuffixOf, intersperse)--import Trace.Hpc.Mix--import Data.Bifunctor (second)-import Data.Set (Set)-import qualified Data.Set as Set--{--************************************************************************-*                                                                      *-*              The main function: addTicksToBinds-*                                                                      *-************************************************************************--}---- | Configuration for compilation pass to add tick for instrumentation--- to binding sites.-data TicksConfig = TicksConfig-  { ticks_passes       :: ![TickishType]-  -- ^ What purposes do we need ticks for--  , ticks_profAuto     :: !ProfAuto-  -- ^ What kind of {-# SCC #-} to add automatically--  , ticks_countEntries :: !Bool-  -- ^ Whether to count the entries to functions-  ---  -- Requires extra synchronization which can vastly degrade-  -- performance.-  }--data Tick = Tick-  { tick_loc   :: SrcSpan   -- ^ Tick source span-  , tick_path  :: [String]  -- ^ Path to the declaration-  , tick_ids   :: [OccName] -- ^ Identifiers being bound-  , tick_label :: BoxLabel  -- ^ Label for the tick counter-  }---addTicksToBinds-        :: Logger-        -> TicksConfig-        -> Module-        -> ModLocation          -- ^ location of the current module-        -> NameSet              -- ^ Exported Ids.  When we call addTicksToBinds,-                                -- isExportedId doesn't work yet (the desugarer-                                -- hasn't set it), so we have to work from this set.-        -> [TyCon]              -- ^ Type constructors in this module-        -> LHsBinds GhcTc-        -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick))--addTicksToBinds logger cfg-                mod mod_loc exports tyCons binds-  | let passes = ticks_passes cfg-  , not (null passes)-  , Just orig_file <- ml_hs_file mod_loc = do--     let  orig_file2 = guessSourceFile binds orig_file--          tickPass tickish (binds,st) =-            let env = TTE-                      { fileName     = mkFastString orig_file2-                      , declPath     = []-                      , tte_countEntries = ticks_countEntries cfg-                      , exports      = exports-                      , inlines      = emptyVarSet-                      , inScope      = emptyVarSet-                      , blackList    = Set.fromList $-                                       mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of-                                                             RealSrcSpan l _ -> Just l-                                                             UnhelpfulSpan _ -> Nothing)-                                                tyCons-                      , density      = mkDensity tickish $ ticks_profAuto cfg-                      , this_mod     = mod-                      , tickishType  = tickish-                      }-                (binds',_,st') = unTM (addTickLHsBinds binds) env st-            in (binds', st')--          (binds1,st) = foldr tickPass (binds, initTTState) passes--          extendedMixEntries = ticks st--     putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell-       (pprLHsBinds binds1)--     return (binds1, Just (orig_file2, extendedMixEntries))--  | otherwise = return (binds, Nothing)--guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath-guessSourceFile binds orig_file =-     -- Try look for a file generated from a .hsc file to a-     -- .hs file, by peeking ahead.-     let top_pos = catMaybes $ foldr (\ (L pos _) rest ->-                               srcSpanFileName_maybe (locA pos) : rest) [] binds-     in-     case top_pos of-        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name-                      -> unpackFS file_name-        _ -> orig_file----- -------------------------------------------------------------------------------- TickDensity---- | Where to insert ticks-data TickDensity-  = TickForCoverage       -- ^ for Hpc-  | TickForBreakPoints    -- ^ for GHCi-  | TickAllFunctions      -- ^ for -prof-auto-all-  | TickTopFunctions      -- ^ for -prof-auto-top-  | TickExportedFunctions -- ^ for -prof-auto-exported-  | TickCallSites         -- ^ for stack tracing-  deriving Eq--mkDensity :: TickishType -> ProfAuto -> TickDensity-mkDensity tickish pa = case tickish of-  HpcTicks             -> TickForCoverage-  SourceNotes          -> TickForCoverage-  Breakpoints          -> TickForBreakPoints-  ProfNotes ->-    case pa of-      ProfAutoAll      -> TickAllFunctions-      ProfAutoTop      -> TickTopFunctions-      ProfAutoExports  -> TickExportedFunctions-      ProfAutoCalls    -> TickCallSites-      _other           -> panic "mkDensity"---- | Decide whether to add a tick to a binding or not.-shouldTickBind  :: TickDensity-                -> Bool         -- ^ top level?-                -> Bool         -- ^ exported?-                -> Bool         -- ^ simple pat bind?-                -> Bool         -- ^ INLINE pragma?-                -> Bool--shouldTickBind density top_lev exported _simple_pat inline- = case density of-      TickForBreakPoints    -> False-        -- we never add breakpoints to simple pattern bindings-        -- (there's always a tick on the rhs anyway).-      TickAllFunctions      -> not inline-      TickTopFunctions      -> top_lev && not inline-      TickExportedFunctions -> exported && not inline-      TickForCoverage       -> True-      TickCallSites         -> False--shouldTickPatBind :: TickDensity -> Bool -> Bool-shouldTickPatBind density top_lev-  = case density of-      TickForBreakPoints    -> False-      TickAllFunctions      -> True-      TickTopFunctions      -> top_lev-      TickExportedFunctions -> False-      TickForCoverage       -> False-      TickCallSites         -> False---- Strip ticks HsExpr---- | Strip CoreTicks from an HsExpr-stripTicksTopHsExpr :: HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)-stripTicksTopHsExpr (XExpr (HsTick t e)) = let (ts, body) = stripTicksTopHsExpr (unLoc e)-                                            in (t:ts, body)-stripTicksTopHsExpr e = ([], e)---- -------------------------------------------------------------------------------- Adding ticks to bindings--addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)-addTickLHsBinds = mapM addTickLHsBind--addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)-addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds-                                                 , abs_exports = abs_exports-                                                 }))) =-  withEnv add_exports $-    withEnv add_inlines $ do-      binds' <- addTickLHsBinds binds-      return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }-  where-   -- in AbsBinds, the Id on each binding is not the actual top-level-   -- Id that we are defining, they are related by the abs_exports-   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need-   -- to add the local Ids to the set of exported Names so that we know to-   -- tick the right bindings.-   add_exports env =-     env{ exports = exports env `extendNameSetList`-                      [ idName mid-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports-                      , idName pid `elemNameSet` (exports env) ] }--   -- See Note [inline sccs]-   add_inlines env =-     env{ inlines = inlines env `extendVarSetList`-                      [ mid-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports-                      , isInlinePragma (idInlinePragma pid) ] }--addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do-  let name = getOccString id-  decl_path <- getPathEntry-  density <- getDensity--  inline_ids <- liftM inlines getEnv-  -- See Note [inline sccs]-  let inline   = isInlinePragma (idInlinePragma id)-                 || id `elemVarSet` inline_ids--  -- See Note [inline sccs]-  tickish <- tickishType `liftM` getEnv-  case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do--  (fvs, mg) <--        getFreeVars $-        addPathEntry name $-        addTickMatchGroup False (fun_matches funBind)--  blackListed <- isBlackListed (locA pos)-  exported_names <- liftM exports getEnv--  -- We don't want to generate code for blacklisted positions-  -- We don't want redundant ticks on simple pattern bindings-  -- We don't want to tick non-exported bindings in TickExportedFunctions-  let simple = isSimplePatBind funBind-      toplev = null decl_path-      exported = idName id `elemNameSet` exported_names--  tick <- if not blackListed &&-               shouldTickBind density toplev exported simple inline-             then-                bindTick density name (locA pos) fvs-             else-                return Nothing--  let mbCons = maybe Prelude.id (:)-  return $ L pos $ funBind { fun_matches = mg-                           , fun_ext = second (tick `mbCons`) (fun_ext funBind) }-  }--   where-   -- a binding is a simple pattern binding if it is a funbind with-   -- zero patterns-   isSimplePatBind :: HsBind GhcTc -> Bool-   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0---- TODO: Revisit this-addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs-                                    , pat_rhs = rhs }))) = do--  let simplePatId = isSimplePat lhs--  -- TODO: better name for rhs's for non-simple patterns?-  let name = maybe "(...)" getOccString simplePatId--  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False False rhs-  let pat' = pat { pat_rhs = rhs'}--  -- Should create ticks here?-  density <- getDensity-  decl_path <- getPathEntry-  let top_lev = null decl_path-  if not (shouldTickPatBind density top_lev)-    then return (L pos pat')-    else do--    let mbCons = maybe id (:)--    let (initial_rhs_ticks, initial_patvar_tickss) = snd $ pat_ext pat'--    -- Allocate the ticks--    rhs_tick <- bindTick density name (locA pos) fvs-    let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks--    patvar_tickss <- case simplePatId of-      Just{} -> return initial_patvar_tickss-      Nothing -> do-        let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs)-        patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars-        return-          (zipWith mbCons patvar_ticks-                          (initial_patvar_tickss ++ repeat []))--    return $ L pos $ pat' { pat_ext = second (const (rhs_ticks, patvar_tickss)) (pat_ext pat') }---- Only internal stuff, not from source, uses VarBind, so we ignore it.-addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind-addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind--bindTick-  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)-bindTick density name pos fvs = do-  decl_path <- getPathEntry-  let-      toplev        = null decl_path-      count_entries = toplev || density == TickAllFunctions-      top_only      = density /= TickAllFunctions-      box_label     = if toplev then TopLevelBox [name]-                                else LocalBox (decl_path ++ [name])-  ---  allocATickBox box_label count_entries top_only pos fvs----- Note [inline sccs]--- ~~~~~~~~~~~~~~~~~~--- The reason not to add ticks to INLINE functions is that this is--- sometimes handy for avoiding adding a tick to a particular function--- (see #6131)------ So for now we do not add any ticks to INLINE functions at all.------ We used to use isAnyInlinePragma to figure out whether to avoid adding--- ticks for this purpose. However, #12962 indicates that this contradicts--- the documentation on profiling (which only mentions INLINE pragmas).--- So now we're more careful about what we avoid adding ticks to.---- -------------------------------------------------------------------------------- Decorate an LHsExpr with ticks---- selectively add ticks to interesting expressions-addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExpr e@(L pos e0) = do-  d <- getDensity-  case d of-    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it-    TickForCoverage    | XExpr (ExpandedThingTc OrigStmt{} _) <- e0 -- expansion ticks are handled separately-                       -> dont_tick_it-                       | otherwise -> tick_it-    TickCallSites      | isCallSite e0      -> tick_it-    _other             -> dont_tick_it- where-   tick_it      = allocTickBox (ExpBox False) False False (locA pos)-                  $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- Add a tick to an expression which is the RHS of an equation or a binding.--- We always consider these to be breakpoints, unless the expression is a 'let'--- (because the body will definitely have a tick somewhere).  ToDo: perhaps--- we should treat 'case' and 'if' the same way?-addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprRHS e@(L pos e0) = do-  d <- getDensity-  case d of-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it-                        | otherwise     -> tick_it-     TickForCoverage -> tick_it-     TickCallSites   | isCallSite e0 -> tick_it-     _other          -> dont_tick_it- where-   tick_it      = allocTickBox (ExpBox False) False False (locA pos)-                  $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- The inner expression of an evaluation context:---    let binds in [], ( [] )--- we never tick these if we're doing HPC, but otherwise--- we treat it like an ordinary expression.-addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprEvalInner e = do-   d <- getDensity-   case d of-     TickForCoverage -> addTickLHsExprNever e-     _otherwise      -> addTickLHsExpr e---- | A let body is treated differently from addTickLHsExprEvalInner--- above with TickForBreakPoints, because for breakpoints we always--- want to tick the body, even if it is not a redex.  See test--- break012.  This gives the user the opportunity to inspect the--- values of the let-bound variables.-addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprLetBody e@(L pos e0) = do-  d <- getDensity-  case d of-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it-                        | otherwise     -> tick_it-     _other -> addTickLHsExprEvalInner e- where-   tick_it      = allocTickBox (ExpBox False) False False (locA pos)-                  $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- version of addTick that does not actually add a tick,--- because the scope of this tick is completely subsumed by--- another.-addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprNever (L pos e0) = do-    e1 <- addTickHsExpr e0-    return $ L pos e1---- General heuristic: expressions which are calls (do not denote--- values) are good break points.-isGoodBreakExpr :: HsExpr GhcTc -> Bool-isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt{}) _)) = False-isGoodBreakExpr e = isCallSite e--isCallSite :: HsExpr GhcTc -> Bool-isCallSite HsApp{}     = True-isCallSite HsAppType{} = True-isCallSite HsCase{}    = True-isCallSite (XExpr (ExpandedThingTc _ e))-  = isCallSite e---- NB: OpApp, SectionL, SectionR are all expanded out-isCallSite _           = False--addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprOptAlt oneOfMany e@(L pos e0)-  = ifDensity TickForCoverage-        (allocTickBox (ExpBox oneOfMany) False False (locA pos)-                           $ addTickHsExpr e0)-        (addTickLHsExpr e)--addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addBinTickLHsExpr boxLabel e@(L pos e0)-  = ifDensity TickForCoverage-        (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)-        (addTickLHsExpr e)----- -------------------------------------------------------------------------------- Decorate the body of an HsExpr with ticks.--- (Whether to put a tick around the whole expression was already decided,--- in the addTickLHsExpr family of functions.)--addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)-addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e-addTickHsExpr e@(HsUnboundVar {})   = return e--addTickHsExpr e@(HsIPVar {})            = return e-addTickHsExpr e@(HsOverLit {})          = return e-addTickHsExpr e@(HsOverLabel{})         = return e-addTickHsExpr e@(HsLit {})              = return e-addTickHsExpr e@(HsEmbTy {})            = return e-addTickHsExpr e@(HsQual {})             = return e-addTickHsExpr e@(HsForAll {})           = return e-addTickHsExpr e@(HsFunArr {})           = return e-addTickHsExpr (HsLam x v mg)            = liftM (HsLam x v)-                                                (addTickMatchGroup True mg)-addTickHsExpr (HsApp x e1 e2)          = liftM2 (HsApp x) (addTickLHsExprNever e1)-                                                          (addTickLHsExpr      e2)-addTickHsExpr (HsAppType x e ty) = do-        e' <- addTickLHsExprNever e-        return (HsAppType x e' ty)-addTickHsExpr (OpApp fix e1 e2 e3) =-        liftM4 OpApp-                (return fix)-                (addTickLHsExpr e1)-                (addTickLHsExprNever e2)-                (addTickLHsExpr e3)-addTickHsExpr (NegApp x e neg) =-        liftM2 (NegApp x)-                (addTickLHsExpr e)-                (addTickSyntaxExpr hpcSrcSpan neg)-addTickHsExpr (HsPar x e) = do-        e' <- addTickLHsExprEvalInner e-        return (HsPar x e')-addTickHsExpr (SectionL x e1 e2) =-        liftM2 (SectionL x)-                (addTickLHsExpr e1)-                (addTickLHsExprNever e2)-addTickHsExpr (SectionR x e1 e2) =-        liftM2 (SectionR x)-                (addTickLHsExprNever e1)-                (addTickLHsExpr e2)-addTickHsExpr (ExplicitTuple x es boxity) =-        liftM2 (ExplicitTuple x)-                (mapM addTickTupArg es)-                (return boxity)-addTickHsExpr (ExplicitSum ty tag arity e) = do-        e' <- addTickLHsExpr e-        return (ExplicitSum ty tag arity e')-addTickHsExpr (HsCase x e mgs) =-        liftM2 (HsCase x)-                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily-                                   -- be evaluated.-                (addTickMatchGroup False mgs)--addTickHsExpr (HsIf x e1 e2 e3) =-        liftM3 (HsIf x)-                (addBinTickLHsExpr (BinBox CondBinBox) e1)-                (addTickLHsExprOptAlt True e2)-                (addTickLHsExprOptAlt True e3)-addTickHsExpr (HsMultiIf ty alts)-  = do { let isOneOfMany = case alts of [_] -> False; _ -> True-       ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts-       ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet x binds e) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do-          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.-          e' <- addTickLHsExprLetBody e-          return (HsLet x binds' e')-addTickHsExpr (ExplicitList ty es)-  = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es)--addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e--addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })-  = do { rec_binds' <- addTickHsRecordBinds rec_binds-       ; return (expr { rcon_flds = rec_binds' }) }--addTickHsExpr expr@(RecordUpd { rupd_expr = e-                              , rupd_flds = upd@(RegularRecUpdFields { recUpdFields = flds }) })-  = do { e' <- addTickLHsExpr e-       ; flds' <- mapM addTickHsRecField flds-       ; return (expr { rupd_expr = e', rupd_flds = upd { recUpdFields = flds' } }) }-addTickHsExpr expr@(RecordUpd { rupd_expr = e-                              , rupd_flds = upd@(OverloadedRecUpdFields { olRecUpdFields = flds } ) })-  = do { e' <- addTickLHsExpr e-       ; flds' <- mapM addTickHsRecField flds-       ; return (expr { rupd_expr = e', rupd_flds = upd { olRecUpdFields = flds' } }) }--addTickHsExpr (ExprWithTySig x e ty) =-        liftM3 ExprWithTySig-                (return x)-                (addTickLHsExprNever e) -- No need to tick the inner expression-                                        -- for expressions with signatures-                (return ty)-addTickHsExpr (ArithSeq ty wit arith_seq) =-        liftM3 ArithSeq-                (return ty)-                (addTickWit wit)-                (addTickArithSeqInfo arith_seq)-             where addTickWit Nothing = return Nothing-                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl-                                             return (Just fl')--addTickHsExpr (HsPragE x p e) =-        liftM (HsPragE x p) (addTickLHsExpr e)-addTickHsExpr e@(HsTypedBracket {})  = return e-addTickHsExpr e@(HsUntypedBracket{}) = return e-addTickHsExpr e@(HsTypedSplice{})    = return e-addTickHsExpr e@(HsUntypedSplice{})  = return e-addTickHsExpr e@(HsGetField {})      = return e-addTickHsExpr e@(HsProjection {})    = return e-addTickHsExpr (HsProc x pat cmdtop) =-        liftM2 (HsProc x)-                (addTickLPat pat)-                (traverse (addTickHsCmdTop) cmdtop)-addTickHsExpr (XExpr (WrapExpr w e)) =-        liftM (XExpr . WrapExpr w) $-              (addTickHsExpr e)        -- Explicitly no tick on inside-addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e--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---- We might encounter existing ticks (multiple Coverage passes)-addTickHsExpr (XExpr (HsTick t e)) =-        liftM (XExpr . HsTick t) (addTickLHsExprNever e)-addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =-        liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)--addTickHsExpr e@(XExpr (HsRecSelTc (FieldOcc _ id)))   = do freeVar (unLoc id); return e--addTickHsExpr (HsDo srcloc cxt (L l stmts))-  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())-       ; return (HsDo srcloc cxt (L l stmts')) }-  where-        forQual = case cxt of-                    ListComp -> Just $ BinBox QualBinBox-                    _        -> Nothing--addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)-addTickHsExpanded o@(OrigStmt (L pos LastStmt{})) e-  -- LastStmt always gets a tick for breakpoint and hpc coverage-  = do d <- getDensity-       case d of-          TickForCoverage    -> liftM (XExpr . ExpandedThingTc o) $ tick_it e-          TickForBreakPoints -> liftM (XExpr . ExpandedThingTc o) $ tick_it e-          _                  -> liftM (XExpr . ExpandedThingTc o) $ addTickHsExpr e-  where-    tick_it e  = unLoc <$> allocTickBox (ExpBox False) False False (locA pos)-                               (addTickHsExpr e)-addTickHsExpanded o e-  = liftM (XExpr . ExpandedThingTc o) $ addTickHsExpr e---addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)-addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e-                                  ; return (Present x e') }-addTickTupArg (Missing ty) = return (Missing ty)---addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)-                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))-addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches, mg_ext = ctxt }) = do-  let isOneOfMany = matchesOneOfMany matches-      isDoExp     = isDoExpansionGenerated $ mg_origin ctxt-  matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam isDoExp)) matches-  return $ mg { mg_alts = L l matches' }--addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} ->  Match GhcTc (LHsExpr GhcTc)-             -> TM (Match GhcTc (LHsExpr GhcTc))-addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats-                                                       , m_grhss = gRHSs }) =-  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do-    gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs-    return $ match { m_grhss = gRHSs' }--addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)-             -> TM (GRHSs GhcTc (LHsExpr GhcTc))-addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) =-  bindLocals binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded-    return $ GRHSs x guarded' local_binds'-  where-    binders = collectLocalBinders CollNoDictBinders local_binds--addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)-            -> TM (GRHS GhcTc (LHsExpr GhcTc))-addTickGRHS isOneOfMany isLambda isDoExp (GRHS x stmts expr) = do-  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts-                        (addTickGRHSBody isOneOfMany isLambda isDoExp expr)-  return $ GRHS x stmts' expr'--addTickGRHSBody :: Bool -> Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickGRHSBody isOneOfMany isLambda isDoExp expr@(L pos e0) = do-  d <- getDensity-  case d of-    TickForBreakPoints-      | isDoExp       -- ticks for do-expansions are handled by `addTickHsExpanded`-      -> addTickLHsExprNever expr-      | otherwise-      -> addTickLHsExprRHS expr-    TickForCoverage-      | isDoExp       -- ticks for do-expansions are handled by `addTickHsExpanded`-      -> addTickLHsExprNever expr-      | otherwise-      -> addTickLHsExprOptAlt isOneOfMany expr-    TickAllFunctions | isLambda ->-       addPathEntry "\\" $-         allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $-           addTickHsExpr e0-    _otherwise ->-       addTickLHsExprRHS expr--addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]-              -> TM [ExprLStmt GhcTc]-addTickLStmts isGuard stmts = do-  (stmts, _) <- addTickLStmts' isGuard stmts (return ())-  return stmts--addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a-               -> TM ([ExprLStmt GhcTc], a)-addTickLStmts' isGuard lstmts res-  = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $-    do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts-       ; a <- res-       ; return (lstmts', a) }--addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)-            -> TM (Stmt GhcTc (LHsExpr GhcTc))-addTickStmt _isGuard (LastStmt x e noret ret) =-        liftM3 (LastStmt x)-                (addTickLHsExpr e)-                (pure noret)-                (addTickSyntaxExpr hpcSrcSpan ret)-addTickStmt _isGuard (BindStmt xbs pat e) =-        liftM4 (\b f -> BindStmt $ XBindStmtTc-                    { xbstc_bindOp = b-                    , xbstc_boundResultType = xbstc_boundResultType xbs-                    , xbstc_boundResultMult = xbstc_boundResultMult xbs-                    , xbstc_failOp = f-                    })-                (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))-                (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))-                (addTickLPat pat)-                (addTickLHsExprRHS e)-addTickStmt isGuard (BodyStmt x e bind' guard') =-        liftM3 (BodyStmt x)-                (addTick isGuard e)-                (addTickSyntaxExpr hpcSrcSpan bind')-                (addTickSyntaxExpr hpcSrcSpan guard')-addTickStmt _isGuard (LetStmt x binds) =-        liftM (LetStmt x)-                (addTickHsLocalBinds binds)-addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) =-    liftM3 (ParStmt x)-        (mapM (addTickStmtAndBinders isGuard) pairs)-        (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr))-        (addTickSyntaxExpr hpcSrcSpan bindExpr)--addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts-                                    , trS_by = by, trS_using = using-                                    , trS_ret = returnExpr, trS_bind = bindExpr-                                    , trS_fmap = liftMExpr }) = do-    t_s <- addTickLStmts isGuard stmts-    t_y <- traverse  addTickLHsExprRHS by-    t_u <- addTickLHsExprRHS using-    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr-    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr-    t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr))-    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u-                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }--addTickStmt isGuard stmt@(RecStmt {})-  = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt)-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }--addTickStmt isGuard (XStmtLR (ApplicativeStmt body_ty args mb_join)) = do-    args' <- mapM (addTickApplicativeArg isGuard) args-    return (XStmtLR (ApplicativeStmt body_ty args' mb_join))--addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e-                  | otherwise          = addTickLHsExprRHS e--addTickApplicativeArg-  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)-  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)-addTickApplicativeArg isGuard (op, arg) =-  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)- where-  addTickArg (ApplicativeArgOne m_fail pat expr isBody) =-    ApplicativeArgOne-      <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail-      <*> addTickLPat pat-      <*> addTickLHsExpr expr-      <*> pure isBody-  addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =-    (ApplicativeArgMany x)-      <$> addTickLStmts isGuard stmts-      <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))-      <*> addTickLPat pat-      <*> pure ctxt--addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc-                      -> TM (ParStmtBlock GhcTc GhcTc)-addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =-    liftM3 (ParStmtBlock x)-        (addTickLStmts isGuard stmts)-        (return ids)-        (addTickSyntaxExpr hpcSrcSpan returnExpr)--addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)-addTickHsLocalBinds (HsValBinds x binds) =-        liftM (HsValBinds x)-                (addTickHsValBinds binds)-addTickHsLocalBinds (HsIPBinds x binds)  =-        liftM (HsIPBinds x)-                (addTickHsIPBinds binds)-addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)--addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)-                  -> TM (HsValBindsLR GhcTc (GhcPass b))-addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do-        b <- liftM2 NValBinds-                (mapM (\ (rec,binds') ->-                                liftM2 (,)-                                        (return rec)-                                        (addTickLHsBinds binds'))-                        binds)-                (return sigs)-        return $ XValBindsLR b-addTickHsValBinds _ = panic "addTickHsValBinds"--addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)-addTickHsIPBinds (IPBinds dictbinds ipbinds) =-        liftM2 IPBinds-                (return dictbinds)-                (mapM (traverse (addTickIPBind)) ipbinds)--addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)-addTickIPBind (IPBind x nm e) =-        liftM (IPBind x nm)-               (addTickLHsExpr e)---- There is no location here, so we might need to use a context location??-addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)-addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do-        x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x))-        return $ syn { syn_expr = x' }-addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc---- we do not walk into patterns.-addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)-addTickLPat pat = return pat--addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)-addTickHsCmdTop (HsCmdTop x cmd) =-        liftM2 HsCmdTop-                (return x)-                (addTickLHsCmd cmd)--addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)-addTickLHsCmd (L pos c0) = do-        c1 <- addTickHsCmd c0-        return $ L pos c1--addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)-addTickHsCmd (HsCmdLam x lam_variant mgs) =-        liftM (HsCmdLam x lam_variant) (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdApp x c e) =-        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)-{--addTickHsCmd (OpApp e1 c2 fix c3) =-        liftM4 OpApp-                (addTickLHsExpr e1)-                (addTickLHsCmd c2)-                (return fix)-                (addTickLHsCmd c3)--}-addTickHsCmd (HsCmdPar x e) = do-        e' <- addTickLHsCmd e-        return (HsCmdPar x e')-addTickHsCmd (HsCmdCase x e mgs) =-        liftM2 (HsCmdCase x)-                (addTickLHsExpr e)-                (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =-        liftM3 (HsCmdIf x cnd)-                (addBinTickLHsExpr (BinBox CondBinBox) e1)-                (addTickLHsCmd c2)-                (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet x binds c) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do-          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.-          c' <- addTickLHsCmd c-          return (HsCmdLet x binds' c')-addTickHsCmd (HsCmdDo srcloc (L l stmts))-  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())-       ; return (HsCmdDo srcloc (L l stmts')) }--addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =-        liftM5 HsCmdArrApp-               (return arr_ty)-               (addTickLHsExpr e1)-               (addTickLHsExpr e2)-               (return ty1)-               (return lr)-addTickHsCmd (HsCmdArrForm x e f cmdtop) =-        liftM3 (HsCmdArrForm x)-               (addTickLHsExpr e)-               (return f)-               (mapM (traverse (addTickHsCmdTop)) cmdtop)--addTickHsCmd (XCmd (HsWrap w cmd)) =-  liftM XCmd $-  liftM (HsWrap w) (addTickHsCmd cmd)---- Others should never happen in a command context.---addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)--addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)-                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))-addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do-  matches' <- mapM (traverse addTickCmdMatch) matches-  return $ mg { mg_alts = L l matches' }--addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))-addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) =-  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do-    gRHSs' <- addTickCmdGRHSs gRHSs-    return $ match { m_grhss = gRHSs' }--addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))-addTickCmdGRHSs (GRHSs x guarded local_binds) =-  bindLocals binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (traverse addTickCmdGRHS) guarded-    return $ GRHSs x guarded' local_binds'-  where-    binders = collectLocalBinders CollNoDictBinders local_binds--addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))--- The *guards* are *not* Cmds, although the body is--- C.f. addTickGRHS for the BinBox stuff-addTickCmdGRHS (GRHS x stmts cmd)-  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)-                                   stmts (addTickLHsCmd cmd)-       ; return $ GRHS x stmts' expr' }--addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]-                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]-addTickLCmdStmts stmts = do-  (stmts, _) <- addTickLCmdStmts' stmts (return ())-  return stmts--addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a-                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)-addTickLCmdStmts' lstmts res-  = bindLocals binders $ do-        lstmts' <- mapM (traverse addTickCmdStmt) lstmts-        a <- res-        return (lstmts', a)-  where-        binders = collectLStmtsBinders CollNoDictBinders lstmts--addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))-addTickCmdStmt (BindStmt x pat c) =-        liftM2 (BindStmt x)-                (addTickLPat pat)-                (addTickLHsCmd c)-addTickCmdStmt (LastStmt x c noret ret) =-        liftM3 (LastStmt x)-                (addTickLHsCmd c)-                (pure noret)-                (addTickSyntaxExpr hpcSrcSpan ret)-addTickCmdStmt (BodyStmt x c bind' guard') =-        liftM3 (BodyStmt x)-                (addTickLHsCmd c)-                (addTickSyntaxExpr hpcSrcSpan bind')-                (addTickSyntaxExpr hpcSrcSpan guard')-addTickCmdStmt (LetStmt x binds) =-        liftM (LetStmt x)-                (addTickHsLocalBinds binds)-addTickCmdStmt stmt@(RecStmt {})-  = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt)-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }-addTickCmdStmt (XStmtLR (ApplicativeStmt{})) =-  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"---- Others should never happen in a command context.-addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)--addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)-addTickHsRecordBinds (HsRecFields x fields dd)-  = do  { fields' <- mapM addTickHsRecField fields-        ; return (HsRecFields x fields' dd) }--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 (HsFieldBind x id expr' pun)) }--addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)-addTickArithSeqInfo (From e1) =-        liftM From-                (addTickLHsExpr e1)-addTickArithSeqInfo (FromThen e1 e2) =-        liftM2 FromThen-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-addTickArithSeqInfo (FromTo e1 e2) =-        liftM2 FromTo-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-addTickArithSeqInfo (FromThenTo e1 e2 e3) =-        liftM3 FromThenTo-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-                (addTickLHsExpr e3)--data TickTransState = TT { ticks       :: !(SizedSeq Tick)-                         , ccIndices   :: !CostCentreState-                         }--initTTState :: TickTransState-initTTState = TT { ticks        = emptySS-                 , ccIndices    = newCostCentreState-                 }--addMixEntry :: Tick -> TM Int-addMixEntry ent = do-  c <- fromIntegral . sizeSS . ticks <$> getState-  setState $ \st ->-    st { ticks = addToSS (ticks st) ent-       }-  return c--data TickTransEnv = TTE { fileName     :: FastString-                        , density      :: TickDensity-                        , tte_countEntries :: !Bool-                          -- ^ Whether the number of times functions are-                          -- entered should be counted.-                        , exports      :: NameSet-                        , inlines      :: VarSet-                        , declPath     :: [String]-                        , inScope      :: VarSet-                        , blackList    :: Set RealSrcSpan-                        , this_mod     :: Module-                        , tickishType  :: TickishType-                        }----      deriving Show---- | Reasons why we need ticks,-data TickishType-  -- | For profiling-  = ProfNotes-  -- | For Haskell Program Coverage-  | HpcTicks-  -- | For ByteCode interpreter break points-  | Breakpoints-  -- | For source notes-  | SourceNotes-  deriving (Eq)---- | Tickishs that only make sense when their source code location--- refers to the current file. This might not always be true due to--- LINE pragmas in the code - which would confuse at least HPC.-tickSameFileOnly :: TickishType -> Bool-tickSameFileOnly HpcTicks = True-tickSameFileOnly _other   = False--type FreeVars = OccEnv Id-noFVs :: FreeVars-noFVs = emptyOccEnv---- Note [freevars]--- ~~~~~~~~~~~~~~~---   For breakpoints we want to collect the free variables of an---   expression for pinning on the HsTick.  We don't want to collect---   *all* free variables though: in particular there's no point pinning---   on free variables that are will otherwise be in scope at the GHCi---   prompt, which means all top-level bindings.  Unfortunately detecting---   top-level bindings isn't easy (collectHsBindsBinders on the top-level---   bindings doesn't do it), so we keep track of a set of "in-scope"---   variables in addition to the free variables, and the former is used---   to filter additions to the latter.  This gives us complete control---   over what free variables we track.--newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }-    deriving (Functor)-        -- a combination of a state monad (TickTransState) and a writer-        -- monad (FreeVars).--instance Applicative TM where-    pure a = TM $ \ _env st -> (a,noFVs,st)-    (<*>) = ap--instance Monad TM where-  (TM m) >>= k = TM $ \ env st ->-                                case m env st of-                                  (r1,fv1,st1) ->-                                     case unTM (k r1) env st1 of-                                       (r2,fv2,st2) ->-                                          (r2, fv1 `plusOccEnv` fv2, st2)----- | Get the next HPC cost centre index for a given centre name-getCCIndexM :: FastString -> TM CostCentreIndex-getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $-                                                 ccIndices st-                              in (idx, noFVs, st { ccIndices = is' })--getState :: TM TickTransState-getState = TM $ \ _ st -> (st, noFVs, st)--setState :: (TickTransState -> TickTransState) -> TM ()-setState f = TM $ \ _ st -> ((), noFVs, f st)--getEnv :: TM TickTransEnv-getEnv = TM $ \ env st -> (env, noFVs, st)--withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a-withEnv f (TM m) = TM $ \ env st ->-                                 case m (f env) st of-                                   (a, fvs, st') -> (a, fvs, st')--getDensity :: TM TickDensity-getDensity = TM $ \env st -> (density env, noFVs, st)--ifDensity :: TickDensity -> TM a -> TM a -> TM a-ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el--getFreeVars :: TM a -> TM (FreeVars, a)-getFreeVars (TM m)-  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')--freeVar :: Id -> TM ()-freeVar id = TM $ \ env st ->-                if id `elemVarSet` inScope env-                   then ((), unitOccEnv (nameOccName (idName id)) id, st)-                   else ((), noFVs, st)--addPathEntry :: String -> TM a -> TM a-addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })--getPathEntry :: TM [String]-getPathEntry = declPath `liftM` getEnv--getFileName :: TM FastString-getFileName = fileName `liftM` getEnv--isGoodSrcSpan' :: SrcSpan -> Bool-isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos-isGoodSrcSpan' (UnhelpfulSpan _) = False--isGoodTickSrcSpan :: SrcSpan -> TM Bool-isGoodTickSrcSpan pos = do-  file_name <- getFileName-  tickish <- tickishType `liftM` getEnv-  let need_same_file = tickSameFileOnly tickish-      same_file      = Just file_name == srcSpanFileName_maybe pos-  return (isGoodSrcSpan' pos && (not need_same_file || same_file))--ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a-ifGoodTickSrcSpan pos then_code else_code = do-  good <- isGoodTickSrcSpan pos-  if good then then_code else else_code--bindLocals :: [Id] -> TM a -> TM a-bindLocals new_ids (TM m)-  = TM $ \ env st ->-                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of-                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')-  where occs = [ nameOccName (idName id) | id <- new_ids ]--isBlackListed :: SrcSpan -> TM Bool-isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st)-isBlackListed (UnhelpfulSpan _) = return False---- the tick application inherits the source position of its--- expression argument to support nested box allocations-allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)-             -> TM (LHsExpr GhcTc)-allocTickBox boxLabel countEntries topOnly pos m =-  ifGoodTickSrcSpan pos (do-    (fvs, e) <- getFreeVars m-    env <- getEnv-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e)))-  (do-    e <- m-    return (L (noAnnSrcSpan pos) e)-  )---- the tick application inherits the source position of its--- expression argument to support nested box allocations-allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars-              -> TM (Maybe CoreTickish)-allocATickBox boxLabel countEntries topOnly  pos fvs =-  ifGoodTickSrcSpan pos (do-    let-      mydecl_path = case boxLabel of-                      TopLevelBox x -> x-                      LocalBox xs  -> xs-                      _ -> panic "allocATickBox"-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path-    return (Just tickish)-  ) (return Nothing)---mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]-          -> TM CoreTickish-mkTickish boxLabel countEntries topOnly pos fvs decl_path = do--  let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs-          -- unlifted types cause two problems here:-          --   * we can't bind them  at the GHCi prompt-          --     (bindLocalsAtBreakpoint already filters them out),-          --   * the simplifier might try to substitute a literal for-          --     the Id, and we can't handle that.--      me = Tick-        { tick_loc   = pos-        , tick_path  = decl_path-        , tick_ids   = map (nameOccName.idName) ids-        , tick_label = boxLabel-        }--      cc_name | topOnly   = mkFastString $ head decl_path-              | otherwise = mkFastString $ concat (intersperse "." decl_path)--  env <- getEnv-  case tickishType env of-    HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me--    ProfNotes -> do-      flavour <- mkHpcCCFlavour <$> getCCIndexM cc_name-      let cc = mkUserCC cc_name (this_mod env) pos flavour-          count = countEntries && tte_countEntries env-      return $ ProfNote cc count True{-scopes-}--    Breakpoints -> do-      i <- addMixEntry me-      pure (Breakpoint noExtField i ids (this_mod env))--    SourceNotes | RealSrcSpan pos' _ <- pos ->-      return $ SourceNote pos' $ LexicalFastString cc_name--    _otherwise -> panic "mkTickish: bad source span!"---allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)-                -> TM (LHsExpr GhcTc)-allocBinTickBox boxLabel pos m = do-  env <- getEnv-  case tickishType env of-    HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m-                   ifGoodTickSrcSpan pos-                     (mkBinTickBoxHpc boxLabel pos e)-                     (return e)-    _other   -> allocTickBox (ExpBox False) False False pos m--mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc-                -> TM (LHsExpr GhcTc)-mkBinTickBoxHpc boxLabel pos e = do-  env <- getEnv-  binTick <- HsBinTick-    <$> addMixEntry (Tick { tick_loc = pos-                          , tick_path = declPath env-                          , tick_ids = []-                          , tick_label = boxLabel True-                          })-    <*> addMixEntry (Tick { tick_loc = pos-                          , tick_path = declPath env-                          , tick_ids = []-                          , tick_label = boxLabel False-                          })-    <*> pure e-  tick <- HpcTick (this_mod env)-    <$> addMixEntry (Tick { tick_loc = pos-                          , tick_path = declPath env-                          , tick_ids = []-                          , tick_label = ExpBox False-                          })-  let pos' = noAnnSrcSpan pos-  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))--hpcSrcSpan :: SrcSpan-hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")--matchesOneOfMany :: [LMatch GhcTc body] -> Bool-matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1-  where-        matchCount :: LMatch GhcTc body -> Int-        matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))-          = length grhss
compiler/GHC/HsToCore/Types.hs view
@@ -14,27 +14,34 @@ import GHC.Prelude (Int)  import Data.IORef-import qualified Data.Set as S  import GHC.Types.CostCentre.State import GHC.Types.Error import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Var+import GHC.Types.Var.Set import GHC.Types.Name.Reader (GlobalRdrEnv)+ import GHC.Hs (LForeignDecl, HsExpr, GhcTc)+ import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv)+ import GHC.HsToCore.Pmc.Types (Nablas) import GHC.HsToCore.Errors.Types+ import GHC.Core (CoreExpr) import GHC.Core.FamInstEnv import GHC.Utils.Outputable as Outputable import GHC.Unit.Module import GHC.Driver.Hooks (DsForeignsHook) import GHC.Data.OrdList (OrdList)+ import GHC.Types.ForeignStubs (ForeignStubs) import GHC.Types.CompleteMatch +import Data.Maybe( Maybe )+ {- ************************************************************************ *                                                                      *@@ -80,9 +87,11 @@   -- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".   -- The set of reaching values Nablas is augmented as we walk inwards, refined   -- through each pattern match in turn-  , dsl_unspecables :: S.Set EvVar-  -- ^ See Note [Desugaring non-canonical evidence]: this field collects-  -- all un-specialisable evidence variables in scope.++  , dsl_unspecables :: Maybe VarSet+  -- ^ See Note [Desugaring non-canonical evidence]+  -- This field collects all un-specialisable evidence variables in scope.+  -- Nothing <=> don't collect this info (used for the LHS of Rules)   }  -- Inside [| |] brackets, the desugarer looks
compiler/GHC/HsToCore/Usage.hs view
@@ -1,7 +1,3 @@---{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore.Usage (     -- * Dependency/fingerprinting code (used by GHC.Iface.Make)     mkUsageInfo, mkUsedNames,@@ -23,8 +19,10 @@ import GHC.Utils.Panic import GHC.Utils.Monad +import GHC.Types.Avail import GHC.Types.Name-import GHC.Types.Name.Set ( NameSet, allUses )+import GHC.Types.Name.Reader (ImpDeclSpec(..))+import GHC.Types.Name.Set ( NameSet, allUses, emptyNameSet, unionNameSet ) import GHC.Types.Unique.Set  import GHC.Unit@@ -48,10 +46,10 @@ import GHC.Unit.Finder import GHC.Types.Unique.DFM import GHC.Driver.Plugins+import qualified GHC.Unit.Home.Graph as HUG  {- Note [Module self-dependency]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in its own dep_orphs or dep_finsts. However, if we aren't careful this can occur in the presence of hs-boot files: Consider that we have two modules, A and B,@@ -75,19 +73,23 @@   { uc_safe_implicit_imps_req :: !Bool -- ^ Are all implicit imports required to be safe for this Safe Haskell mode?   } -mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv -> Module -> ImportedMods -> NameSet -> [FilePath]-            -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IfG [Usage]-mkUsageInfo uc plugins fc unit_env this_mod dir_imp_mods used_names dependent_files merged needed_links needed_pkgs+mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv+            -> Module -> ImportedMods -> [ImportUserSpec] -> NameSet+            -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded+            -> IfG [Usage]+mkUsageInfo uc plugins fc unit_env+  this_mod dir_imp_mods imp_decls used_names+  dependent_files merged needed_links needed_pkgs   = do     eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env))     hashes <- liftIO $ mapM getFileHash dependent_files-    let hu = unsafeGetHomeUnit unit_env+    let hu = ue_unsafeHomeUnit unit_env         hug = ue_home_unit_graph unit_env     -- Dependencies on object files due to TH and plugins     object_usages <- liftIO $ mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs-    let all_home_ids = ue_all_home_unit_ids unit_env+    let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env)     mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod-                                       dir_imp_mods used_names+                                       dir_imp_mods imp_decls used_names     let usages = mod_usages ++ [ UsageFile { usg_file_path = mkFastString f                                            , usg_file_hash = hash                                            , usg_file_label = Nothing }@@ -104,8 +106,7 @@     -- the entire collection of Ifaces.  {- Note [Plugin dependencies]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Modules for which plugins were used in the compilation process, should be recompiled whenever one of those plugins changes. But how do we know if a plugin changed from the previous time a module was compiled?@@ -184,11 +185,11 @@         Nothing ->  do           -- This should only happen for home package things but oneshot puts           -- home package ifaces in the PIT.-          let miface = lookupIfaceByModule hug pit m+          miface <- lookupIfaceByModule hug pit m           case miface of             Nothing -> pprPanic "mkObjectUsage" (ppr m)             Just iface ->-              return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash (mi_final_exts iface))+              return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash iface)      librarySpecToUsage :: LibrarySpec -> IO [Usage]     librarySpecToUsage (Objects os) = traverse (fing Nothing) os@@ -201,9 +202,10 @@               -> Set.Set UnitId               -> Module               -> ImportedMods+              -> [ImportUserSpec]               -> NameSet               -> IfG [Usage]-mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports used_names+mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls used_names   = mapMaybeM mkUsageM usage_mods   where     safe_implicit_imps_req = uc_safe_implicit_imps_req uc@@ -264,7 +266,7 @@         -- for package modules, we record the module hash only        | (null used_occs-          && isNothing export_hash+          && isNothing imported_exports           && not is_direct_import           && not finsts_mod)       = Nothing                 -- Record no usage info@@ -277,15 +279,24 @@                       usg_mod_name = moduleName mod,                       usg_unit_id  = toUnitId (moduleUnit mod),                       usg_mod_hash = mod_hash,-                      usg_exports  = export_hash,+                      usg_exports  = imported_exports,                       usg_entities = Map.toList ent_hashs,                       usg_safe     = imp_safe }       where-        finsts_mod   = mi_finsts (mi_final_exts iface)-        hash_env     = mi_hash_fn (mi_final_exts iface)-        mod_hash     = mi_mod_hash (mi_final_exts iface)-        export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface))-                    | otherwise         = Nothing+        finsts_mod = mi_finsts iface+        hash_env   = mi_hash_fn iface+        mod_hash   = mi_mod_hash iface+        imported_exports+          = if not depend_on_exports+            then Nothing+            else+              Just $+                HomeModImport+                 { hmiu_orphanLikeHash+                     = mi_orphan_like_hash iface+                 , hmiu_importedAvails+                     = moduleImportedAvails mod (mi_export_avails_hash iface) imp_decls+                 }          by_is_safe (ImportedByUser imv) = imv_is_safe imv         by_is_safe _ = False@@ -334,9 +345,30 @@               one-shot mode), but that's even more bogus!         -} -{--Note [Internal used_names]-~~~~~~~~~~~~~~~~~~~~~~~~~~+-- | Compute the avails that we are importing from a home module.+--+-- See 'HomeModImportedAvails'.+moduleImportedAvails :: Module -> Fingerprint -> [ImportUserSpec] -> HomeModImportedAvails+moduleImportedAvails mod vis_exp_hash = go [] emptyNameSet+  where+    go :: Avails -> NameSet -> [ImportUserSpec] -> HomeModImportedAvails+    go avails_acc parents_acc [] =+      HMIA_Explicit+        { hmia_imported_avails = sortAvails avails_acc+        , hmia_parents_with_implicits = parents_acc+        }+    go avails_acc parents_acc (ImpUserSpec (ImpDeclSpec { is_mod = mod' }) decl : imp_decls)+      | mod' == mod+      = case decl of+          ImpUserExplicit avails parents_of_implicits+            -> go (avails ++ avails_acc) (parents_acc `unionNameSet` parents_of_implicits)+                  imp_decls+          _ -> HMIA_Implicit vis_exp_hash+      | otherwise+      = go avails_acc parents_acc imp_decls++{- Note [Internal used_names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Most of the used_names are External Names, but we can have System Names too. Two examples: 
compiler/GHC/HsToCore/Utils.hs view
@@ -28,8 +28,7 @@         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,         wrapBind, wrapBinds, -        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,-        mkFailExpr,+        mkErrorAppDs, mkCastDs, mkFailExpr,          seqVar, @@ -42,9 +41,6 @@         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,         mkOptTickBox, mkBinaryTickBox, decideBangHood,         isTrueLHsExpr,--        -- Multiplicity-        checkMultiplicityCoercions,     ) where  import GHC.Prelude@@ -58,7 +54,6 @@ import GHC.Hs.Syn.Type import GHC.Core import GHC.HsToCore.Monad-import GHC.HsToCore.Errors.Types  import GHC.Core.Utils import GHC.Core.Make@@ -77,7 +72,6 @@ import GHC.Types.Unique.Supply import GHC.Unit.Module import GHC.Builtin.Names-import GHC.Types.Name( isInternalName ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc@@ -90,7 +84,7 @@ import GHC.Rename.Env ( irrefutableConLikeTc ) import GHC.Tc.Types.Evidence -import Control.Monad    ( unless, zipWithM )+import Control.Monad    ( zipWithM ) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (maybeToList) import qualified Data.List.NonEmpty as NEL@@ -205,10 +199,13 @@  shiftEqns :: Functor f => f EquationInfoNE -> f EquationInfo -- Drop the first pattern in each equation-shiftEqns = fmap eqn_rest+shiftEqns = fmap shift+  where+    shift (EqnMatch { eqn_rest = rest }) = rest+    shift eqn@(EqnDone {}) = pprPanic "shiftEqns" (ppr eqn)  combineEqnRhss :: NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)-combineEqnRhss eqns = return $ foldr1 combineMatchResults $ map eqnMatchResult (NEL.toList eqns)+combineEqnRhss = pure . foldr1 combineMatchResults . fmap eqnMatchResult  -- Functions on MatchResult CoreExprs @@ -337,7 +334,7 @@     matcher <- dsLExpr $ mkLHsWrap wrapper $                          nlHsTyApp matcher_id [getRuntimeRep ty, ty]     cont <- mkCoreLams bndrs <$> runMatchResult fail match_result-    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]+    return $ mkCoreApps matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]   where     MkCaseAlt{ alt_pat = psyn,                alt_bndrs = bndrs,@@ -469,102 +466,6 @@ mkFailExpr ctxt ty   = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) -{--'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'.--Note [Desugaring seq]-~~~~~~~~~~~~~~~~~~~~~--There are a few subtleties in the desugaring of `seq`:-- 1. (as described in #1031)--    Consider,-       f x y = x `seq` (y `seq` (# x,y #))--    Because the argument to the outer 'seq' has an unlifted type, we'll use-    call-by-value, and compile it as if we had--       f x y = case (y `seq` (# x,y #)) of v -> x `seq` v--    But that is bad, because we now evaluate y before x!--    Seq is very, very special!  So we recognise it right here, and desugar to-            case x of _ -> case y of _ -> (# x,y #)-- 2. (as described in #2273)--    Consider-       let chp = case b of { True -> fst x; False -> 0 }-       in chp `seq` ...chp...-    Here the seq is designed to plug the space leak of retaining (snd x)-    for too long.--    If we rely on the ordinary inlining of seq, we'll get-       let chp = case b of { True -> fst x; False -> 0 }-       case chp of _ { I# -> ...chp... }--    But since chp is cheap, and the case is an alluring context, we'll-    inline chp into the case scrutinee.  Now there is only one use of chp,-    so we'll inline a second copy.  Alas, we've now ruined the purpose of-    the seq, by re-introducing the space leak:-        case (case b of {True -> fst x; False -> 0}) of-          I# _ -> ...case b of {True -> fst x; False -> 0}...--    We can try to avoid doing this by ensuring that the binder-swap in the-    case happens, so we get this at an early stage:-       case chp of chp2 { I# -> ...chp2... }-    But this is fragile.  The real culprit is the source program.  Perhaps we-    should have said explicitly-       let !chp2 = chp in ...chp2...--    But that's painful.  So the code here does a little hack to make seq-    more robust: a saturated application of 'seq' is turned *directly* into-    the case expression, thus:-       x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!-       e1 `seq` e2 ==> case x of _ -> e2--    So we desugar our example to:-       let chp = case b of { True -> fst x; False -> 0 }-       case chp of chp { I# -> ...chp... }-    And now all is well.--    The reason it's a hack is because if you define mySeq=seq, the hack-    won't work on mySeq.-- 3. (as described in #2409)--    The isInternalName ensures that we don't turn-            True `seq` e-    into-            case True of True { ... }-    which stupidly tries to bind the datacon 'True'.--}---- NB: Make sure the argument is not representation-polymorphic-mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr-mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2-  | f `hasKey` seqIdKey            -- Note [Desugaring seq], points (1) and (2)-  = Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2]-  where-    case_bndr = case arg1 of-                   Var v1 | isInternalName (idName v1)-                          -> v1        -- Note [Desugaring seq], points (2) and (3)-                   _      -> mkWildValBinder ManyTy ty1--mkCoreAppDs _ (Var f `App` Type _r) arg-  | f `hasKey` noinlineIdKey   -- See Note [noinlineId magic] in GHC.Types.Id.Make-  , (fun, args) <- collectArgs arg-  , not (null args)-  = (Var f `App` Type (exprType fun) `App` fun)-    `mkCoreApps` args--mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in GHC.Core.Make---- NB: No argument can be representation-polymorphic-mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr-mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args- mkCastDs :: CoreExpr -> Coercion -> CoreExpr -- We define a desugarer-specific version of GHC.Core.Utils.mkCast, -- because in the immediate output of the desugarer, we can have@@ -1109,9 +1010,3 @@  isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e isTrueLHsExpr _                 = Nothing---- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.-checkMultiplicityCoercions :: MultiplicityCheckCoercions -> DsM ()-checkMultiplicityCoercions cos =-  unless (all isReflexiveCo cos) $-    diagnosticDs DsMultiplicityCoercionsNotSupported
compiler/GHC/Iface/Binary.hs view
@@ -43,14 +43,12 @@ import GHC.Utils.Panic import GHC.Utils.Binary as Binary import GHC.Data.FastMutInt-import GHC.Data.FastString (FastString) import GHC.Types.Unique import GHC.Utils.Outputable import GHC.Types.Name.Cache import GHC.Types.SrcLoc import GHC.Platform import GHC.Settings.Constants-import GHC.Utils.Fingerprint import GHC.Iface.Type (IfaceType(..), getIfaceType, putIfaceType, ifaceTypeSharedByte)  import Control.Monad@@ -115,7 +113,7 @@   -> CheckHiWay   -> TraceBinIFace   -> FilePath-  -> IO (Fingerprint, ReadBinHandle)+  -> IO ReadBinHandle readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do     let platform = profilePlatform profile @@ -157,8 +155,7 @@     when (checkHiWay == CheckHiWay) $         errorOnMismatch "mismatched interface file profile tag" tag check_tag -    src_hash <- get bh-    pure (src_hash, bh)+    pure bh  -- | Read an interface file. --@@ -171,12 +168,11 @@   -> FilePath   -> IO ModIface readBinIface profile name_cache checkHiWay traceBinIface hi_path = do-    (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path+    bh <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path      mod_iface <- getIfaceWithExtFields name_cache bh      return $ mod_iface-      & addSourceFingerprint src_hash   getIfaceWithExtFields :: NameCache -> ReadBinHandle -> IO ModIface@@ -260,7 +256,6 @@     put_ bh (show hiVersion)     let tag = profileBuildTag profile     put_  bh tag-    put_  bh (mi_src_hash mod_iface)      putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface @@ -321,18 +316,21 @@   (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel    -- Initialise the 'WriterUserData'.-  let writerUserData = mkWriterUserData-        [ mkSomeBinaryWriter @FastString fsWriter-        , mkSomeBinaryWriter @Name nameWriter-        -- We sometimes serialise binding and non-binding names differently, but-        -- not during 'ModIface' serialisation. Here, we serialise both to the same-        -- deduplication table.-        ---        -- See Note [Binary UserData]-        , mkSomeBinaryWriter @BindingName  $ mkWriter (\bh name -> putEntry nameWriter bh (getBindingName name))-        , mkSomeBinaryWriter @IfaceType ifaceTypeWriter-        ]-  let bh = setWriterUserData bh' writerUserData+  --+  -- Similar to how 'getTables' calls 'addReaderToUserData', here we+  -- call 'addWriterToUserData' instead of 'setWriterUserData', to+  -- avoid overwriting existing writers of other types in bh'.+  let bh =+        addWriterToUserData fsWriter+          $ addWriterToUserData nameWriter+          -- We sometimes serialise binding and non-binding names differently, but+          -- not during 'ModIface' serialisation. Here, we serialise both to the same+          -- deduplication table.+          --+          -- See Note [Binary UserData]+          $ addWriterToUserData+            (mkWriter $ \bh name -> putEntry nameWriter bh $ getBindingName name)+          $ addWriterToUserData ifaceTypeWriter bh'    ([fs_count, name_count, ifacetype_count] , r) <-     -- The order of these entries matters!
compiler/GHC/Iface/Env.hs view
@@ -15,7 +15,7 @@          ifaceExportNames, -        trace_if, trace_hi_diffs,+        trace_if, trace_hi_diffs, trace_hi_diffs_io,          -- Name-cache stuff         allocateGlobalBinder,@@ -272,6 +272,12 @@ {-# INLINE trace_if #-} -- see Note [INLINE conditional tracing utilities] trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc +trace_hi_diffs_io :: Logger -> IO SDoc -> IO ()+{-# INLINE trace_hi_diffs_io #-} -- see Note [INLINE conditional tracing utilities]+trace_hi_diffs_io logger doc =+  when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $+    doc >>= putMsg logger+ trace_hi_diffs :: Logger -> SDoc -> IO () {-# INLINE trace_hi_diffs #-} -- see Note [INLINE conditional tracing utilities]-trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc+trace_hi_diffs logger doc = trace_hi_diffs_io logger (pure doc)
compiler/GHC/Iface/Errors.hs view
@@ -87,7 +87,7 @@ cannotFindModule' :: UnitEnv -> Profile -> ModuleName -> FindResult                   -> MissingInterfaceError cannotFindModule' unit_env profile mod res =-  CantFindErr (ue_units unit_env) FindingModule $+  CantFindErr (ue_homeUnitState unit_env) FindingModule $   cantFindErr unit_env               profile               mod@@ -131,7 +131,7 @@                  | otherwise                 -> GenericMissing-                    (map ((\uid -> (uid, lookupUnit (ue_units unit_env) uid))) pkg_hiddens)+                    (map ((\uid -> (uid, lookupUnit (ue_homeUnitState unit_env) uid))) pkg_hiddens)                     mod_hiddens unusables files             _ -> panic "cantFindErr" 
compiler/GHC/Iface/Ext/Ast.hs view
@@ -14,7 +14,6 @@ {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- For the HasLoc instances  {-@@ -33,21 +32,21 @@ import GHC.Data.BooleanFormula import GHC.Core.Class             ( className, classSCSelIds ) import GHC.Core.ConLike           ( conLikeName )-import GHC.Core.FVs import GHC.Core.DataCon           ( dataConNonlinearType ) import GHC.Types.FieldLabel import GHC.Hs import GHC.Hs.Syn.Type import GHC.Utils.Monad            ( concatMapM, MonadIO(liftIO) )+import GHC.Utils.FV               ( fvVarList, filterFV ) import GHC.Types.Id               ( isDataConId_maybe )-import GHC.Types.Name             ( Name, nameSrcSpan, nameUnique, wiredInNameTyThing_maybe )+import GHC.Types.Name             ( Name, nameSrcSpan, nameUnique, wiredInNameTyThing_maybe, getName ) import GHC.Types.Name.Env         ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )-import GHC.Types.Name.Reader      ( RecFieldInfo(..) )+import GHC.Types.Name.Reader      ( RecFieldInfo(..), WithUserRdr(..) ) import GHC.Types.SrcLoc-import GHC.Core.Type              ( Type )+import GHC.Core.Type              ( Type, ForAllTyFlag(..) ) import GHC.Core.TyCon             ( TyCon, tyConClass_maybe )-import GHC.Core.Predicate import GHC.Core.InstEnv+import GHC.Core.Predicate         ( isEvId ) import GHC.Tc.Types import GHC.Tc.Types.Evidence import GHC.Types.Var              ( Id, Var, EvId, varName, varType, varUnique )@@ -55,10 +54,10 @@ import GHC.Builtin.Uniques import GHC.Iface.Make             ( mkIfaceExports ) import GHC.Utils.Panic-import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Data.FastString import qualified GHC.Data.Strict as Strict+import GHC.Data.Pair  import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils@@ -83,6 +82,7 @@ import Control.Applicative        ( (<|>) ) import GHC.Types.TypeEnv          ( TypeEnv ) import Control.Arrow              ( second )+import Data.Traversable           ( mapAccumR )  {- Note [Updating HieAst for changes in the GHC AST]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -305,7 +305,7 @@           -> TcGblEnv           -> RenamedSource -> m HieFile mkHieFile ms ts rs = do-  let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms)+  let src_file = expectJust (ml_hs_file $ ms_location ms)   src <- liftIO $ BS.readFile src_file   pure $ mkHieFileWithSource src_file src ms ts rs @@ -432,7 +432,7 @@  grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns)            => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan-grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs)+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (NE.map getLocA xs)  bindingsOnly :: [Context Name] -> HieM [HieAST a] bindingsOnly [] = pure []@@ -508,36 +508,19 @@ -- things to its right, ala RScoped  -- | Each element scopes over the elements to the right-listScopes :: Scope -> [LocatedA a] -> [RScoped (LocatedA a)]-listScopes _ [] = []-listScopes rhsScope [pat] = [RS rhsScope pat]-listScopes rhsScope (pat : pats) = RS sc pat : pats'-  where-    pats'@((RS scope p):_) = listScopes rhsScope pats-    sc = combineScopes scope $ mkScope $ getLocA p+listScopes :: Traversable f => Scope -> f (LocatedA a) -> f (RScoped (LocatedA a))+listScopes = fmap snd . mapAccumR (\ (scope :: Scope) pat -> let scope' = combineScopes scope $ mkScope $ getLocA pat in (scope', RS scope pat))  -- | 'listScopes' specialised to 'PScoped' things patScopes-  :: Maybe Span+  :: Traversable f+  => Maybe Span   -> Scope   -> Scope-  -> [LPat (GhcPass p)]-  -> [PScoped (LPat (GhcPass p))]-patScopes rsp useScope patScope xs =-  map (\(RS sc a) -> PS rsp useScope sc a) $-    listScopes patScope xs---- | 'listScopes' specialised to 'HsConPatTyArg'-taScopes-  :: Scope-  -> Scope-  -> [HsConPatTyArg (GhcPass a)]-  -> [TScoped (HsTyPat (GhcPass a))]-taScopes scope rhsScope xs =-  map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $-    listScopes rhsScope (map (\(HsConPatTyArg _ hstp) -> L (getLoc $ hstp_body hstp) hstp) xs)-  -- We make the HsTyPat into a Located one by using the location of the underlying LHsType.-  -- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS.+  -> f (LPat (GhcPass p))+  -> f (PScoped (LPat (GhcPass p)))+patScopes rsp useScope patScope =+    fmap (\(RS sc a) -> PS rsp useScope sc a) . listScopes patScope  -- | 'listScopes' specialised to 'TVScoped' things tvScopes@@ -576,9 +559,9 @@ instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where   getHasLoc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of     HsOuterImplicit{} ->-      foldl1' combineSrcSpans [getHasLoc a, getHasLocList b, getHasLoc c]+      foldl1' combineSrcSpans (getHasLoc a :| getHasLocList b : getHasLoc c : [])     HsOuterExplicit{hso_bndrs = tvs} ->-      foldl1' combineSrcSpans [getHasLoc a, getHasLocList tvs, getHasLocList b, getHasLoc c]+      foldl1' combineSrcSpans (getHasLoc a :| getHasLocList tvs : getHasLocList b : getHasLoc c : [])  instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg (GhcPass p) tm ty) where   getHasLoc (HsValArg _ tm) = getHasLoc tm@@ -686,22 +669,19 @@               []]       _ -> pure [] -evVarsOfTermList :: EvTerm -> [EvId]-evVarsOfTermList (EvExpr e)         = exprSomeFreeVarsList isEvVar e-evVarsOfTermList (EvTypeable _ ev)  =-  case ev of-    EvTypeableTyCon _ e   -> concatMap evVarsOfTermList e-    EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2]-    EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3]-    EvTypeableTyLit e     -> evVarsOfTermList e-evVarsOfTermList (EvFun{}) = []+instance ToHie (Context (Located (WithUserRdr Name))) where+  toHie (C c (L l (WithUserRdr _ n))) = toHie $ C c (L l n) +hieEvIdsOfTerm :: EvTerm -> [EvId]+-- Returns only EvIds satisfying relevantEvId+hieEvIdsOfTerm tm = fvVarList (filterFV isEvId (evTermFVs tm))+ instance ToHie (EvBindContext (LocatedA TcEvBinds)) where   toHie (EvBindContext sc sp (L span (EvBinds bs)))     = concatMapM go $ bagToList bs     where       go evbind = do-          let evDeps = evVarsOfTermList $ eb_rhs evbind+          let evDeps = hieEvIdsOfTerm $ eb_rhs evbind               depNames = EvBindDeps $ map varName evDeps           concatM $             [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp)@@ -722,7 +702,7 @@           toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpanA osp))                 $ L osp a         (WpEvApp a) ->-          concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a+          concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a         _               -> pure []  instance HiePass p => HasType (LocatedA (HsBind (GhcPass p))) where@@ -831,13 +811,17 @@       , Data (HsCmdTop (GhcPass p))       , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p))))       , Data (HsUntypedSplice (GhcPass p))+      , Data (HsTypedSplice (GhcPass p))       , Data (HsLocalBinds (GhcPass p))       , Data (FieldOcc (GhcPass p))       , Data (HsTupArg (GhcPass p))       , Data (IPBind (GhcPass p))       , ToHie (Context (Located (IdGhcP p)))+      , ToHie (Context (Located (IdOccGhcP p)))       , Anno (IdGhcP p) ~ SrcSpanAnnN+      , Anno (IdOccGhcP p) ~ SrcSpanAnnN       , Typeable p+      , IsPass p       )       => HiePass p where   hiePass :: HiePassEv p@@ -935,18 +919,21 @@           varScope = mkScope var           patScope = mkScope $ getLoc pat           detScope = case dets of-            (PrefixCon _ args) -> foldr combineScopes NoScope $ map mkScope args+            (PrefixCon args) -> foldr combineScopes NoScope $ map mkScope args             (InfixCon a b) -> combineScopes (mkScope a) (mkScope b)             (RecCon r) -> foldr go NoScope r-          go (RecordPatSynField a b) c = combineScopes c+          go (RecordPatSynField (a :: FieldOcc (GhcPass p)) b) c = combineScopes c             $ combineScopes (mkScope (foLabel a)) (mkScope 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 args) = PrefixCon $ map (C Use) args           toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)           toBind (RecCon r) = RecCon $ map (PSC detSpan) r +instance ToHie a => ToHie (WithUserRdr a) where+  toHie (WithUserRdr _ a) = toHie a+ instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where   toHie dir = case dir of     ExplicitBidirectional mg -> toHie mg@@ -1039,7 +1026,7 @@                             ]             ]           HieRn ->-            [ toHie $ C Use con+            [ toHie $ C Use (fmap getName con)             , toHie $ contextify dets             ]       ViewPat _ expr pat ->@@ -1086,14 +1073,12 @@               ]             ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]     where-      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsConPatTyArg GhcRn) a (HsRecFields (GhcPass p) a)-                 -> HsConDetails (TScoped (HsTyPat GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))-      contextify (PrefixCon tyargs args) =-        PrefixCon (taScopes scope argscope tyargs)-                  (patScopes rsp scope pscope args)-        where argscope = foldr combineScopes NoScope $ map mkScope args+      contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a)+                 -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))+      contextify (PrefixCon args) =+        PrefixCon (patScopes rsp scope pscope args)       contextify (InfixCon a b) = InfixCon a' b'-        where [a', b'] = patScopes rsp scope pscope [a,b]+        where Pair a' b' = patScopes rsp scope pscope (Pair a b)       contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r       contextify_rec (HsRecFields x fds a) = HsRecFields x (map go scoped_fds) a         where@@ -1203,7 +1188,6 @@         [ toHie $ C Use (L mspan var)              -- Patch up var location since typechecker removes it         ]-      HsUnboundVar _ _ -> []  -- there is an unbound name here, but that causes trouble       HsOverLabel {} -> []       HsIPVar _ _ -> []       HsOverLit _ o ->@@ -1276,7 +1260,7 @@         where           con_name :: LocatedN Name           con_name = case hiePass @p of       -- Like ConPat-                       HieRn -> con+                       HieRn -> fmap getName con                        HieTc -> fmap conLikeName con       RecordUpd { rupd_expr = expr                 , rupd_flds = RegularRecUpdFields { recUpdFields = upds } }->@@ -1321,7 +1305,7 @@         HieTc -> dataConCantHappen x       HsFunArr x mult arg res -> case hiePass @p of         HieRn ->-          [ toHie (arrowToHsExpr mult)+          [ toHie (multAnnToHsExpr mult)           , toHie arg           , toHie res           ]@@ -1344,13 +1328,14 @@           , toHie p           ]       HsTypedSplice _ x ->-        [ toHie x+        [ toHie $ L mspan x         ]       HsUntypedSplice _ x ->         [ toHie $ L mspan x         ]       HsGetField {} -> []       HsProjection {} -> []+      HsHole _ -> [] -- there is a hole here, but that causes trouble       XExpr x -> case hiePass @p of         HieTc -> case x of           WrapExpr w a@@ -1531,8 +1516,8 @@     , toHie $ PS Nothing sc NoScope pat     ] -instance (ToHie tyarg, ToHie arg, ToHie rec) => ToHie (HsConDetails tyarg arg rec) where-  toHie (PrefixCon tyargs args) = concatM [ toHie tyargs, toHie args ]+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where+  toHie (PrefixCon args) = toHie args   toHie (RecCon rec) = toHie rec   toHie (InfixCon a b) = concatM [ toHie a, toHie b] @@ -1639,8 +1624,8 @@         ]         where           context_scope = mkScope $ fromMaybe (noLocA []) context-          rhs_scope = foldl1' combineScopes $ map mkScope-            [ getHasLocList deps, getHasLocList sigs, getHasLocList meths, getHasLocList typs, getHasLocList deftyps]+          rhs_scope = foldl1' combineScopes $ NE.map mkScope+            ( getHasLocList deps :| getHasLocList sigs : getHasLocList meths : getHasLocList typs : getHasLocList deftyps : [])  instance ToHie (LocatedA (FamilyDecl GhcRn)) where   toHie (L span decl) = concatM $ makeNodeA decl span : case decl of@@ -1745,21 +1730,20 @@ instance ToHie (LocatedP OverlapMode) where   toHie (L span _) = locOnly (locA span) -instance ToHie a => ToHie (HsScaled GhcRn a) where-  toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t]- instance ToHie (LocatedA (ConDecl GhcRn)) where   toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of-      ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs-                  , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ+      ConDeclGADT { con_names = names+                  , con_outer_bndrs = L outer_bndrs_loc outer_bndrs+                  , con_inner_bndrs = inner_bndrs+                  , con_mb_cxt = ctx+                  , con_g_args = args+                  , con_res_ty = typ                   , con_doc = doc} ->         [ toHie $ C (Decl ConDec $ getRealSpanA span) <$> names-        , case outer_bndrs of-            HsOuterImplicit{hso_ximplicit = imp_vars} ->-              bindingsOnly $ map (C $ TyVarBind (mkScope outer_bndrs_loc) resScope)-                             imp_vars-            HsOuterExplicit{hso_bndrs = exp_bndrs} ->-              toHie $ tvScopes resScope NoScope exp_bndrs+        , bindingsOnly $  -- implicit forall+            map (C $ TyVarBind (mkScope outer_bndrs_loc) (ResolvedScopes [sigmaScope]))+                imp_vars+        , toHie $ tvScopes (ResolvedScopes [phiScope]) NoScope exp_bndrs         , toHie ctx         , toHie args         , toHie typ@@ -1772,7 +1756,14 @@             PrefixConGADT _ xs -> scaled_args_scope xs             RecConGADT _ x     -> mkScope x           tyScope = mkScope typ-          resScope = ResolvedScopes [ctxScope, rhsScope]+          phiScope = combineScopes ctxScope rhsScope+          sigmaScope = foldr combineScopes phiScope (map (mkScope . getLoc) exp_bndrs)+          imp_vars = case outer_bndrs of+            HsOuterImplicit{hso_ximplicit = imp_vars} -> imp_vars+            HsOuterExplicit{} -> []+          exp_bndrs =+            [ L l (updateHsTyVarBndrFlag Invisible b) | L l b <- hsOuterExplicitBndrs outer_bndrs ]+            ++ concatMap hsForAllTelescopeBndrs inner_bndrs       ConDeclH98 { con_name = name, con_ex_tvs = qvars                  , con_mb_cxt = ctx, con_args = dets                  , con_doc = doc} ->@@ -1786,18 +1777,25 @@           rhsScope = combineScopes ctxScope argsScope           ctxScope = maybe NoScope mkScope ctx           argsScope = case dets of-            PrefixCon _ xs -> scaled_args_scope xs-            InfixCon a b   -> scaled_args_scope [a, b]-            RecCon x       -> mkScope x-    where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope-          scaled_args_scope = foldr combineScopes NoScope . map (mkScope . hsScaledThing)+            PrefixCon xs -> scaled_args_scope xs+            InfixCon a b -> scaled_args_scope [a, b]+            RecCon x     -> mkScope x+    where scaled_args_scope :: [HsConDeclField GhcRn] -> Scope+          scaled_args_scope = foldr combineScopes NoScope . map (mkScope . cdf_type) -instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where+instance ToHie (LocatedL [LocatedA (HsConDeclRecField GhcRn)]) where   toHie (L span decls) = concatM $     [ locOnly (locA span)     , toHie decls     ] +instance ToHie (HsConDeclField GhcRn) where+  toHie (CDF { cdf_multiplicity, cdf_type, cdf_doc }) = concatM+    [ toHie (multAnnToHsType cdf_multiplicity)+    , toHie cdf_type+    , toHie cdf_doc+    ]+ instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where   toHie (TS sc (HsWC names a)) = concatM $       [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names@@ -1851,6 +1849,10 @@           [ toHie $ (C Use) name           , toHie $ map (TS (ResolvedScopes [])) typs           ]+        SpecSigE _ bndrs spec_e _ ->+          [ toHieRuleBndrs (locA sp) (mkScope spec_e) bndrs+          , toHie spec_e+          ]         SpecInstSig _ typ ->           [ toHie $ TS (ResolvedScopes []) typ           ]@@ -1907,7 +1909,7 @@         , toHie ki         ]       HsFunTy _ w a b ->-        [ toHie (arrowToHsType w)+        [ toHie (multAnnToHsType w)         , toHie a         , toHie b         ]@@ -1943,12 +1945,6 @@         [ toHie a         , toHie doc         ]-      HsBangTy _ _ ty ->-        [ toHie ty-        ]-      HsRecTy _ fields ->-        [ toHie fields-        ]       HsExplicitListTy _ _ tys ->         [ toHie tys         ]@@ -1997,12 +1993,11 @@     , toHie exprs     ] -instance ToHie (LocatedA (ConDeclField GhcRn)) where+instance ToHie (LocatedA (HsConDeclRecField GhcRn)) where   toHie (L span field) = concatM $ makeNode field (locA span) : case field of-      ConDeclField _ fields typ doc ->-        [ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc typ)) fields+      HsConDeclRecField _ fields typ ->+        [ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc $ cdf_type typ)) fields         , toHie typ-        , toHie doc         ]  instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where@@ -2035,14 +2030,23 @@   toHie (TypBr _ ty) = toHie ty   toHie (VarBr {} )  = pure [] -instance ToHie PendingRnSplice where-  toHie (PendingRnSplice _ _ e) = toHie e+instance forall pass . HiePass pass => ToHie (HsUntypedSplice (GhcPass pass)) where+  toHie (HsUntypedSpliceExpr _ext e) = toHie e+  toHie (HsQuasiQuote _ext quoter _ispanFs) = toHie (C Use quoter)+  toHie (XUntypedSplice ext) =+    case ghcPass @pass of+      GhcRn -> case ext of+        HsImplicitLiftSplice _ _ _ lid -> toHie (C Use lid)  instance ToHie PendingTcSplice where   toHie (PendingTcSplice _ e) = toHie e -instance ToHie (LBooleanFormula (LocatedN Name)) where-  toHie (L span form) = concatM $ makeNode form (locA span) : case form of+instance ToHie PendingRnSplice where+  toHie (PendingRnSplice _ e) = toHie e++instance (HiePass p, Data (IdGhcP p))+  => ToHie (GenLocated SrcSpanAnnL (BooleanFormula (GhcPass p))) where+    toHie (L span form) =  concatM $ makeNode form (locA span) : case form of       Var a ->         [ toHie $ C Use a         ]@@ -2059,7 +2063,7 @@ instance ToHie (LocatedAn NoEpAnns HsIPName) where   toHie (L span e) = makeNodeA e span -instance HiePass p => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where+instance (HiePass p) => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where   toHie (L span sp) = concatM $ makeNodeA sp span : case sp of       HsUntypedSpliceExpr _ expr ->         [ toHie expr@@ -2067,7 +2071,28 @@       HsQuasiQuote _ _ ispanFs ->         [ locOnly (getLocA ispanFs)         ]+      XUntypedSplice x ->+        case ghcPass @p of+          GhcRn -> case x of+            HsImplicitLiftSplice _ _ _ lid ->+              [ toHie $ C Use lid+              ] +instance HiePass p => ToHie (LocatedA (HsTypedSplice (GhcPass p))) where+  toHie (L span sp) =  concatM $ makeNodeA sp span : case sp of+      HsTypedSpliceExpr _ expr ->+        [ toHie expr+        ]+      XTypedSplice x ->+        case ghcPass @p of+          GhcRn -> case x of+            HsImplicitLiftSplice _ _ _ lid ->+              [ toHie $ C Use lid+              ]++++ instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where   toHie (L span annot) = concatM $ makeNodeA annot span : case annot of       RoleAnnotDecl _ var roles ->@@ -2108,7 +2133,6 @@  instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where   toHie (C c (FieldOcc _ l)) = toHie (C c l)-  toHie (C _ (XFieldOcc _))  = concatM []  instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where   toHie (PSC sp (RecordPatSynField a b)) = concatM $@@ -2194,19 +2218,26 @@         ]  instance ToHie (LocatedA (RuleDecl GhcRn)) where-  toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM+  toHie (L span r@(HsRule { rd_name = rname, rd_bndrs = bndrs+                          , rd_lhs = exprA, rd_rhs = exprB }))+    = concatM         [ makeNodeA r span         , locOnly $ getLocA rname-        , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs-        , toHie $ map (RS $ mkScope (locA span)) bndrs+        , toHieRuleBndrs (locA span) scope bndrs         , toHie exprA         , toHie exprB         ]-    where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc-          bndrs_sc = maybe NoScope mkScope (listToMaybe bndrs)-          exprA_sc = mkScope exprA-          exprB_sc = mkScope exprB+    where+      scope = mkScope exprA `combineScopes` mkScope exprB +toHieRuleBndrs :: SrcSpan -> Scope -> RuleBndrs GhcRn -> HieM [HieAST Type]+toHieRuleBndrs span body_sc (RuleBndrs { rb_tyvs = tybndrs, rb_tmvs = bndrs })+    = concatM [ toHie $ fmap (tvScopes (ResolvedScopes []) full_sc) tybndrs+              , toHie $ map (RS $ mkScope (locA span)) bndrs ]+    where+      full_sc = bndrs_sc `combineScopes` body_sc+      bndrs_sc = maybe NoScope mkScope (listToMaybe bndrs)+ instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where   toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of       RuleBndr _ var ->@@ -2271,6 +2302,9 @@         [ toHie $ C (IEThing c) (L l p)         ]       IEType _ (L l n) ->+        [ toHie $ C (IEThing c) (L l n)+        ]+      IEData _ (L l n) ->         [ toHie $ C (IEThing c) (L l n)         ] 
compiler/GHC/Iface/Load.hs view
@@ -35,6 +35,8 @@         pprModIfaceSimple,         ifaceStats, pprModIface, showIface, +        getGhcPrimIface,+         module Iface_Errors -- avoids boot files in Ppr modules    ) where @@ -46,7 +48,6 @@    ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst    , tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceDefaults) -import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Errors.Types import GHC.Driver.DynFlags@@ -104,7 +105,7 @@ import GHC.Unit.Module.Deps import GHC.Unit.State import GHC.Unit.Home-import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable import GHC.Unit.Finder import GHC.Unit.Env @@ -118,6 +119,8 @@ import {-# source #-} GHC.Driver.Main (loadIfaceByteCode) import GHC.Iface.Errors.Types import Data.Function ((&))+import GHC.Unit.Module.Graph+import qualified GHC.Unit.Home.Graph as HUG  {- ************************************************************************@@ -442,7 +445,7 @@                 -- Check whether we have the interface already         ; hsc_env <- getTopEnv         ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)-        ; case lookupIfaceByModule hug (eps_PIT eps) mod of {+        ; liftIO (lookupIfaceByModule hug (eps_PIT eps) mod) >>= \case {             Just iface                 -> return (Succeeded iface) ;   -- Already loaded             _ -> do {@@ -504,7 +507,7 @@               ((isOneShot (ghcMode (hsc_dflags hsc_env)))                 || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env                 || mod == gHC_PRIM)-                (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod))+                (text "Attempting to load home package interface into the EPS" $$ ppr (HUG.allUnits hug) $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod))         ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas         ; new_eps_decls     <- tcIfaceDecls ignore_prags (mi_decls iface)         ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)@@ -522,7 +525,7 @@                                & set_mi_fam_insts (panic "No mi_fam_insts in PIT")                                & set_mi_rules     (panic "No mi_rules in PIT")                                & set_mi_anns      (panic "No mi_anns in PIT")-                               & set_mi_extra_decls (panic "No mi_extra_decls in PIT")+                               & set_mi_simplified_core (panic "No mi_simplified_core in PIT")                bad_boot = mi_boot iface == IsBoot                           && isJust (lookupKnotVars (if_rec_types gbl_env) mod)@@ -652,38 +655,55 @@       | otherwise = gbl_env { if_rec_types = emptyKnotVars }     cleanTopEnv hsc_env = -       let-         !maybe_type_vars | inOneShot = Just (hsc_type_env_vars env)-                          | otherwise = Nothing-         -- wrinkle: when we're typechecking in --backpack mode, the-         -- instantiation of a signature might reside in the HPT, so-         -- this case breaks the assumption that EPS interfaces only-         -- refer to other EPS interfaces.-         -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it-         -- contains any hole modules.-         -- Quite a few tests in testsuite/tests/backpack break without this-         -- tweak.-         old_unit_env = hsc_unit_env hsc_env-         keepFor20509 hmi-          | isHoleModule (mi_semantic_module (hm_iface hmi)) = True-          | otherwise = False-         pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }-         !unit_env-          = old_unit_env-             { ue_home_unit_graph = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_home_unit_graph old_unit_env-                                                                                 else unitEnv_map pruneHomeUnitEnv (ue_home_unit_graph old_unit_env)-             }-       in-       hsc_env {  hsc_targets      = panic "cleanTopEnv: hsc_targets"-               ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"-               ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"-               ,  hsc_type_env_vars = case maybe_type_vars of-                                          Just vars -> vars-                                          Nothing -> panic "cleanTopEnv: hsc_type_env_vars"-               ,  hsc_unit_env     = unit_env-               }+      let+        !maybe_type_vars | inOneShot = Just (hsc_type_env_vars env)+                         | otherwise = Nothing+        -- wrinkle: when we're typechecking in --backpack mode, the+        -- instantiation of a signature might reside in the HPT, so+        -- this case breaks the assumption that EPS interfaces only+        -- refer to other EPS interfaces.+        -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it+        -- contains any hole modules.+        -- Quite a few tests in testsuite/tests/backpack break without this+        -- tweak.+        old_unit_env = hsc_unit_env hsc_env+        keepFor20509+         -- oneshot mode does not support backpack+         -- and we want to avoid prodding the hsc_mod_graph thunk+         | isOneShot (ghcMode (hsc_dflags hsc_env)) = False+         | mgHasHoles (ue_module_graph old_unit_env) = True+         | otherwise = False+        pruneHomeUnitEnv hme = do+          -- NB: These are empty HPTs because Iface/Load first consults the HPT+          emptyHPT <- liftIO emptyHomePackageTable+          return $! hme{ homeUnitEnv_hpt = emptyHPT }+        unit_env_io+          | keepFor20509+          = return old_unit_env+          | otherwise+          = do+            hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph old_unit_env)+            let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss"+                                         , mg_graph = panic "cleanTopEnv: mg_graph"+                                         , mg_has_holes = keepFor20509 }+            return old_unit_env+              { ue_home_unit_graph = hug'+              , ue_module_graph    = new_mod_graph+              }+      in do+        !unit_env <- unit_env_io+        -- mg_has_holes will be checked again, but nothing else about the module graph+        pure $+          hsc_env+                {  hsc_targets      = panic "cleanTopEnv: hsc_targets"+                ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"+                ,  hsc_type_env_vars = case maybe_type_vars of+                                           Just vars -> vars+                                           Nothing -> panic "cleanTopEnv: hsc_type_env_vars"+                ,  hsc_unit_env     = unit_env+                } -  updTopEnv cleanTopEnv $ updGblEnv cleanGblEnv $ do+  updTopEnvIO cleanTopEnv $ updGblEnv cleanGblEnv $ do   !_ <- getTopEnv        -- force the updTopEnv   !_ <- getGblEnv   thing_inside@@ -758,13 +778,14 @@         liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+>                  text "to compute precise free module holes")         (eps, hpt) <- getEpsAndHug-        case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of-            Just r -> return (Succeeded r)-            Nothing -> readAndCache imod insts+        result <- tryEpsAndHpt eps hpt+        case result `firstJust` tryDepsCache eps imod insts of+          Just r -> return (Succeeded r)+          Nothing -> readAndCache imod insts     (_, Nothing) -> return (Succeeded emptyUniqDSet)   where     tryEpsAndHpt eps hpt =-        fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod)+        fmap mi_free_holes <$> liftIO (lookupIfaceByModule hpt (eps_PIT eps) mod)     tryDepsCache eps imod insts =         case lookupInstalledModuleEnv (eps_free_holes eps) imod of             Just ifhs  -> Just (renameFreeHoles ifhs insts)@@ -870,13 +891,11 @@    let profile = targetProfile dflags       unit_state = hsc_units hsc_env-      fc         = hsc_FC hsc_env       name_cache = hsc_NC hsc_env       mhome_unit  = hsc_home_unit_maybe hsc_env       dflags     = hsc_dflags hsc_env       logger     = hsc_logger hsc_env       hooks      = hsc_hooks hsc_env-      other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)     trace_if logger (sep [hsep [text "Reading",@@ -887,66 +906,53 @@                            ppr mod <> semi],                      nest 4 (text "reason:" <+> doc_str)]) -  -- Check for GHC.Prim, and return its static interface-  -- See Note [GHC.Prim] in primops.txt.pp.-  -- TODO: make this check a function-  if mod `installedModuleEq` gHC_PRIM-      then do-          let iface = case ghcPrimIfaceHook hooks of-                       Nothing -> ghcPrimIface-                       Just h  -> h-          return (Succeeded (iface, panic "GHC.Prim ModLocation (findAndReadIface)"))-      else do-          let fopts = initFinderOpts dflags-          -- Look for the file-          mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)-          case mb_found of-              InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do-                  -- See Note [Home module load error]-                  case mhome_unit of-                    Just home_unit-                      | isHomeInstalledModule home_unit mod-                      , not (isOneShot (ghcMode dflags))-                      -> return (Failed (HomeModError mod loc))-                    _ -> do-                        r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc)-                        case r of-                          Failed err-                            -> return (Failed $ BadIfaceFile err)-                          Succeeded (iface,_fp)-                            -> do-                                r2 <- load_dynamic_too_maybe logger name_cache unit_state-                                                         (setDynamicNow dflags) wanted_mod-                                                         iface loc-                                case r2 of-                                  Failed sdoc -> return (Failed sdoc)-                                  Succeeded {} -> return $ Succeeded (iface, loc)-              err -> do-                  trace_if logger (text "...not found")-                  return $ Failed $ cannotFindInterface-                                      unit_state-                                      mhome_unit-                                      profile-                                      (moduleName mod)-                                      err+  -- Look for the file+  mb_found <- liftIO (findExactModule hsc_env mod hi_boot_file)+  case mb_found of+      InstalledFound loc -> do+          -- See Note [Home module load error]+          if HUG.memberHugUnitId (moduleUnit mod) (hsc_HUG hsc_env)+              && not (isOneShot (ghcMode dflags))+            then return (Failed (HomeModError mod loc))+            else do+                r <- read_file hooks logger name_cache unit_state dflags wanted_mod (ml_hi_file loc)+                case r of+                  Failed err+                    -> return (Failed $ BadIfaceFile err)+                  Succeeded (iface,_fp)+                    -> do+                        r2 <- load_dynamic_too_maybe hooks logger name_cache unit_state+                                                 (setDynamicNow dflags) wanted_mod+                                                 iface loc+                        case r2 of+                          Failed sdoc -> return (Failed sdoc)+                          Succeeded {} -> return $ Succeeded (iface, loc)+      err -> do+          trace_if logger (text "...not found")+          return $ Failed $ cannotFindInterface+                              unit_state+                              mhome_unit+                              profile+                              (moduleName mod)+                              err  -- | Check if we need to try the dynamic interface for -dynamic-too-load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags+load_dynamic_too_maybe :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags                        -> Module -> ModIface -> ModLocation                        -> IO (MaybeErr MissingInterfaceError ())-load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc+load_dynamic_too_maybe hooks logger name_cache unit_state dflags wanted_mod iface loc   -- Indefinite interfaces are ALWAYS non-dynamic.   | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ())-  | gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc+  | gopt Opt_BuildDynamicToo dflags = load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc   | otherwise = return (Succeeded ()) -load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags+load_dynamic_too :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags                  -> Module -> ModIface -> ModLocation                  -> IO (MaybeErr MissingInterfaceError ())-load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do-  read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case+load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc = do+  read_file hooks logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case     Succeeded (dynIface, _)-     | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface)+     | mi_mod_hash iface == mi_mod_hash dynIface      -> return (Succeeded ())      | otherwise ->         do return $ (Failed $ DynamicHashMismatchError wanted_mod loc)@@ -958,11 +964,10 @@   -read_file :: Logger -> NameCache -> UnitState -> DynFlags+read_file :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags           -> Module -> FilePath           -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath))-read_file logger name_cache unit_state dflags wanted_mod file_path = do-  trace_if logger (text "readIFace" <+> text file_path)+read_file hooks logger name_cache unit_state dflags wanted_mod file_path = do    -- Figure out what is recorded in mi_module.  If this is   -- a fully definite interface, it'll match exactly, but@@ -973,7 +978,7 @@             (_, Just indef_mod) ->               instModuleToModule unit_state                 (uninstantiateInstantiatedModule indef_mod)-  read_result <- readIface dflags name_cache wanted_mod' file_path+  read_result <- readIface hooks logger dflags name_cache wanted_mod' file_path   case read_result of     Failed err      -> return (Failed err)     Succeeded iface -> return (Succeeded (iface, file_path))@@ -1000,12 +1005,15 @@ -- Failed err    <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed readIface-  :: DynFlags+  :: Hooks+  -> Logger+  -> DynFlags   -> NameCache   -> Module   -> FilePath   -> IO (MaybeErr ReadInterfaceError ModIface)-readIface dflags name_cache wanted_mod file_path = do+readIface hooks logger dflags name_cache wanted_mod file_path = do+  trace_if logger (text "readIFace" <+> text file_path)   let profile = targetProfile dflags   res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path   case res of@@ -1014,9 +1022,14 @@         -- critical for correctness of recompilation checking         -- (it lets us tell when -this-unit-id has changed.)         | wanted_mod == actual_mod-                        -> return (Succeeded iface)+                        -> return (Succeeded final_iface)         | otherwise     -> return (Failed err)         where+          final_iface+            -- Check for GHC.Prim, and return its static interface+            -- See Note [GHC.Prim] in primops.txt.pp.+            | wanted_mod == gHC_PRIM = getGhcPrimIface hooks+            | otherwise              = iface           actual_mod = mi_module iface           err = HiModuleNameMismatchWarn file_path wanted_mod actual_mod @@ -1037,11 +1050,10 @@       & set_mi_exports  ghcPrimExports       & set_mi_decls    []       & set_mi_fixities ghcPrimFixities-      & set_mi_final_exts ((mi_final_exts empty_iface)-          { mi_fix_fn = mkIfaceFixCache ghcPrimFixities-          , mi_decl_warn_fn = mkIfaceDeclWarnCache ghcPrimWarns-          , mi_export_warn_fn = mkIfaceExportWarnCache ghcPrimWarns-          })+      & set_mi_fix_fn (mkIfaceFixCache ghcPrimFixities)+      & set_mi_decl_warn_fn (mkIfaceDeclWarnCache ghcPrimWarns)+      & set_mi_export_warn_fn (mkIfaceExportWarnCache ghcPrimWarns)+      & set_mi_fix_fn (mkIfaceFixCache ghcPrimFixities)       & set_mi_docs (Just ghcPrimDeclDocs) -- See Note [GHC.Prim Docs] in GHC.Builtin.Utils       & set_mi_warns (toIfaceWarnings ghcPrimWarns) -- See Note [GHC.Prim Deprecations] in GHC.Builtin.Utils @@ -1099,7 +1111,7 @@    iface <- readBinIface profile name_cache IgnoreHiWay (TraceBinIFace printer) filename     let -- See Note [Name qualification with --show-iface]-       qualifyImportedNames mod _+       qualifyImportedNames mod _user_qual _            | mod == mi_module iface = NameUnqual            | otherwise              = NameNotInScope1        name_ppr_ctx = QueryQualify qualifyImportedNames@@ -1123,37 +1135,36 @@ -- The UnitState is used to pretty-print units pprModIface :: UnitState -> ModIface -> SDoc pprModIface unit_state iface- = vcat [ text "interface"+ = vcat $ [ text "interface"                 <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)-                <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)-                <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty)-                <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty)+                <+> (withSelfRecomp iface empty $ \_ -> text "[self-recomp]")+                <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty)+                <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty)                 <+> integer hiVersion-        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts))-        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts))-        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts))-        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts))-        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts))-        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts))-        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts))-        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts))-        , nest 2 (text "src_hash:" <+> ppr (mi_src_hash iface))+        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))+        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))+        , nest 2 (text "export avails hash:" <+> ppr (mi_export_avails_hash iface))+        , nest 2 (text "orphan-like hash:" <+> ppr (mi_orphan_like_hash iface))+        , withSelfRecomp iface empty ppr+        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))         , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))-        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))         , nest 2 (text "where")         , text "exports:"         , nest 2 (vcat (map pprExport (mi_exports iface)))         , text "defaults:"         , nest 2 (vcat (map ppr (mi_defaults iface)))         , pprDeps unit_state (mi_deps iface)-        , vcat (map pprUsage (mi_usages iface))         , vcat (map pprIfaceAnnotation (mi_anns iface))         , pprFixities (mi_fixities iface)         , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]-        , case mi_extra_decls iface of+        , case mi_simplified_core iface of             Nothing -> empty-            Just eds -> text "extra decls:"-                          $$ nest 2 (vcat ([ppr bs | bs <- eds]))+            Just (IfaceSimplifiedCore eds fs) ->+              vcat [ text "extra decls:"+                           $$ nest 2 (vcat ([ppr bs | bs <- eds]))+                   , text "foreign stubs:"+                           $$ nest 2 (ppr fs)+                   ]         , vcat (map ppr (mi_insts iface))         , vcat (map ppr (mi_fam_insts iface))         , vcat (map ppr (mi_rules iface))@@ -1165,11 +1176,12 @@         , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))         ]   where-    exts = mi_final_exts iface+     pp_hsc_src HsBootFile = text "[boot]"     pp_hsc_src HsigFile   = text "[hsig]"     pp_hsc_src HsSrcFile  = Outputable.empty + {- When printing export lists, we print like this:         Avail   f               f@@ -1189,34 +1201,7 @@     pp_export []    = Outputable.empty     pp_export names = braces (hsep (map ppr names)) -pprUsage :: Usage -> SDoc-pprUsage usage@UsagePackageModule{}-  = pprUsageImport usage usg_mod-pprUsage usage@UsageHomeModule{}-  = pprUsageImport usage (\u -> mkModule (usg_unit_id u) (usg_mod_name u)) $$-    nest 2 (-        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$-        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]-        )-pprUsage usage@UsageFile{}-  = hsep [text "addDependentFile",-          doubleQuotes (ftext (usg_file_path usage)),-          ppr (usg_file_hash usage)]-pprUsage usage@UsageMergedRequirement{}-  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]-pprUsage usage@UsageHomeModuleInterface{}-  = hsep [text "implementation", ppr (usg_mod_name usage)-                               , ppr (usg_unit_id usage)-                               , ppr (usg_iface_hash usage)] -pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc-pprUsageImport usage usg_mod'-  = hsep [text "import", safe, ppr (usg_mod' usage),-                       ppr (usg_mod_hash usage)]-    where-        safe | usg_safe usage = text "safe"-             | otherwise      = text " -/ "- pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities []    = Outputable.empty pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes@@ -1252,3 +1237,15 @@   ppr (ImportByUser NotBoot)               = empty   ppr ImportBySystem                       = text "{- SYSTEM -}"   ppr ImportByPlugin                       = text "{- PLUGIN -}"+++-- | Get gHC_PRIM interface file+--+-- This is a helper function that takes into account the hook allowing ghc-prim+-- interface to be extended via the ghc-api. Afaik it was introduced for GHCJS+-- so that it can add its own primitive types.+getGhcPrimIface :: Hooks -> ModIface+getGhcPrimIface hooks =+  case ghcPrimIfaceHook hooks of+    Nothing -> ghcPrimIface+    Just h  -> h
compiler/GHC/Iface/Make.hs view
@@ -13,6 +13,7 @@    ( mkPartialIface    , mkFullIface    , mkIfaceTc+   , mkRecompUsageInfo    , mkIfaceExports    ) where@@ -21,7 +22,7 @@  import GHC.Hs -import GHC.Stg.InferTags.TagSig (StgCgInfos)+import GHC.Stg.EnforceEpt.TagSig (StgCgInfos) import GHC.StgToCmm.Types (CmmCgInfos (..))  import GHC.Tc.Utils.TcType@@ -47,7 +48,6 @@  import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env-import GHC.Driver.Backend import GHC.Driver.DynFlags import GHC.Driver.Plugins @@ -66,7 +66,6 @@ import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.TyThing-import GHC.Types.HpcInfo import GHC.Types.CompleteMatch import GHC.Types.Name.Cache @@ -89,13 +88,13 @@ import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Deps-import GHC.Unit.Module.WholeCoreBindings (encodeIfaceForeign)+import GHC.Unit.Module.WholeCoreBindings (encodeIfaceForeign, emptyIfaceForeign)  import Data.Function import Data.List ( sortBy ) import Data.Ord import Data.IORef-+import Data.Traversable  {- ************************************************************************@@ -111,23 +110,23 @@                -> ModSummary                -> [ImportUserSpec]                -> ModGuts-               -> PartialModIface+               -> IO PartialModIface mkPartialIface hsc_env core_prog mod_details mod_summary import_decls   ModGuts{ mg_module       = this_mod          , mg_hsc_src      = hsc_src          , mg_usages       = usages-         , mg_used_th      = used_th          , mg_deps         = deps          , mg_rdr_env      = rdr_env          , mg_fix_env      = fix_env          , mg_warns        = warns-         , mg_hpc_info     = hpc_info          , mg_safe_haskell = safe_mode          , mg_trust_pkg    = self_trust          , mg_docs         = docs          }-  = mkIface_ hsc_env this_mod core_prog hsc_src used_th deps rdr_env import_decls fix_env warns hpc_info self_trust-             safe_mode usages docs mod_summary mod_details+  = do+      self_recomp <- traverse (mkSelfRecomp hsc_env this_mod (ms_hs_hash mod_summary)) usages+      return $ mkIface_ hsc_env this_mod core_prog hsc_src deps rdr_env import_decls fix_env warns self_trust+                safe_mode self_recomp docs mod_details  -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information.@@ -144,11 +143,13 @@           = updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos      -- See Note [Foreign stubs and TH bytecode linking]-    foreign_ <- encodeIfaceForeign (hsc_logger hsc_env) (hsc_dflags hsc_env) stubs foreign_files+    mi_simplified_core <- for (mi_simplified_core partial_iface) $ \simpl_core -> do+        fs <- encodeIfaceForeign (hsc_logger hsc_env) (hsc_dflags hsc_env) stubs foreign_files+        return $ (simpl_core { mi_sc_foreign = fs })      full_iface <-       {-# SCC "addFingerprints" #-}-      addFingerprints hsc_env $ set_mi_foreign foreign_ $ set_mi_decls decls partial_iface+      addFingerprints hsc_env $ set_mi_simplified_core mi_simplified_core $ set_mi_decls decls partial_iface      -- Debug printing     let unit_state = hsc_units hsc_env@@ -182,9 +183,8 @@   rbh <- shrinkBinBuffer bh   seekBinReader rbh start   res <- getIfaceWithExtFields nc rbh-  let resiface = restoreFromOldModIface mi res-  forceModIface resiface-  return resiface+  forceModIface res+  return res  -- | Initial ram buffer to allocate for writing interface files. initBinMemSize :: Int@@ -237,64 +237,76 @@                       tcg_import_decls = import_decls,                       tcg_rdr_env = rdr_env,                       tcg_fix_env = fix_env,-                      tcg_merged = merged,-                      tcg_warns = warns,-                      tcg_hpc = other_hpc_info,-                      tcg_th_splice_used = tc_splice_used,-                      tcg_dependent_files = dependent_files+                      tcg_warns = warns                     }   = do-          let used_names = mkUsedNames tc_result           let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))           let home_unit = hsc_home_unit hsc_env           let deps = mkDependencies home_unit                                     (tcg_mod tc_result)                                     (tcg_imports tc_result)                                     (map mi_module pluginModules)-          let hpc_info = emptyHpcInfo other_hpc_info-          used_th <- readIORef tc_splice_used-          dep_files <- (readIORef dependent_files)-          (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result)-          let uc = initUsageConfig hsc_env-              plugins = hsc_plugins hsc_env-              fc = hsc_FC hsc_env-              unit_env = hsc_unit_env hsc_env-          -- Do NOT use semantic module here; this_mod in mkUsageInfo-          -- is used solely to decide if we should record a dependency-          -- or not.  When we instantiate a signature, the semantic-          -- module is something we want to record dependencies for,-          -- but if you pass that in here, we'll decide it's the local-          -- module and does not need to be recorded as a dependency.-          -- See Note [Identity versus semantic module]-          usages <- initIfaceLoad hsc_env $ mkUsageInfo uc plugins fc unit_env this_mod (imp_mods imports) used_names-                      dep_files merged needed_links needed_pkgs +          usage <- mkRecompUsageInfo hsc_env tc_result           docs <- extractDocs (ms_hspp_opts mod_summary) tc_result+          self_recomp <- traverse (mkSelfRecomp hsc_env this_mod (ms_hs_hash mod_summary)) usage            let partial_iface = mkIface_ hsc_env                    this_mod (fromMaybe [] mb_program) hsc_src-                   used_th deps rdr_env import_decls-                   fix_env warns hpc_info-                   (imp_trust_own_pkg imports) safe_mode usages-                   docs mod_summary+                   deps rdr_env import_decls+                   fix_env warns+                   (imp_trust_own_pkg imports) safe_mode self_recomp+                   docs                    mod_details            mkFullIface hsc_env partial_iface Nothing Nothing NoStubs [] +mkRecompUsageInfo :: HscEnv -> TcGblEnv -> IO (Maybe [Usage])+mkRecompUsageInfo hsc_env tc_result = do+  let dflags = hsc_dflags hsc_env+  if not (gopt Opt_WriteSelfRecompInfo dflags)+    then return Nothing+    else do+     let used_names = mkUsedNames tc_result+     dep_files <- (readIORef (tcg_dependent_files tc_result))+     (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result)+     let uc = initUsageConfig hsc_env+         plugins = hsc_plugins hsc_env+         fc = hsc_FC hsc_env+         unit_env = hsc_unit_env hsc_env++     -- Do NOT use semantic module here; this_mod in mkUsageInfo+     -- is used solely to decide if we should record a dependency+     -- or not.  When we instantiate a signature, the semantic+     -- module is something we want to record dependencies for,+     -- but if you pass that in here, we'll decide it's the local+     -- module and does not need to be recorded as a dependency.+     -- See Note [Identity versus semantic module]+     usages <- initIfaceLoad hsc_env $+        mkUsageInfo uc plugins fc unit_env+          (tcg_mod tc_result)+          (imp_mods (tcg_imports tc_result))+          (tcg_import_decls tc_result)+          used_names+          dep_files+          (tcg_merged tc_result)+          needed_links+          needed_pkgs+     return (Just usages)+ mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource-         -> Bool -> Dependencies -> GlobalRdrEnv -> [ImportUserSpec]-         -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo+         -> Dependencies -> GlobalRdrEnv -> [ImportUserSpec]+         -> NameEnv FixItem -> Warnings GhcRn          -> Bool          -> SafeHaskellMode-         -> [Usage]+         -> Maybe IfaceSelfRecomp          -> Maybe Docs-         -> ModSummary          -> ModDetails          -> PartialModIface mkIface_ hsc_env-         this_mod core_prog hsc_src used_th deps rdr_env import_decls fix_env src_warns-         hpc_info pkg_trust_req safe_mode usages-         docs mod_summary+         this_mod core_prog hsc_src deps rdr_env import_decls fix_env src_warns+         pkg_trust_req safe_mode self_recomp+         docs          ModDetails{  md_defaults  = defaults,                       md_insts     = insts,                       md_fam_insts = fam_insts,@@ -314,8 +326,8 @@         entities = typeEnvElts type_env         show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env) -        extra_decls = if gopt Opt_WriteIfSimplifiedCore dflags then Just [ toIfaceTopBind b | b <- core_prog ]-                                                               else Nothing+        simplified_core = if gopt Opt_WriteIfSimplifiedCore dflags then Just (IfaceSimplifiedCore [ toIfaceTopBind b | b <- core_prog ] emptyIfaceForeign)+                                                                   else Nothing         decls  = [ tyThingToIfaceDecl show_linear_types entity                  | entity <- entities,                    let name = getName entity,@@ -342,7 +354,7 @@         trust_info  = setSafeMode safe_mode         annotations = map mkIfaceAnnotation anns         icomplete_matches = map mkIfaceCompleteMatch complete_matches-        !rdrs = maybeGlobalRdrEnv rdr_env+        !rdrs = mkIfaceTopEnv rdr_env      emptyPartialModIface this_mod           -- Need to record this because it depends on the -instantiated-with flag@@ -351,8 +363,8 @@                                       then Nothing                                       else Just semantic_mod)           & set_mi_hsc_src          hsc_src+          & set_mi_self_recomp      self_recomp           & set_mi_deps             deps-          & set_mi_usages           usages           & set_mi_exports          (mkIfaceExports exports)            & set_mi_defaults         (defaultsToIfaceDefaults defaults)@@ -367,17 +379,14 @@           & set_mi_warns            warns           & set_mi_anns             annotations           & set_mi_top_env          rdrs-          & set_mi_used_th          used_th           & set_mi_decls            decls-          & set_mi_extra_decls      extra_decls-          & set_mi_hpc              (isHpcUsed hpc_info)+          & set_mi_simplified_core  simplified_core           & set_mi_trust            trust_info           & set_mi_trust_pkg        pkg_trust_req           & set_mi_complete_matches (icomplete_matches)           & set_mi_docs             docs-          & set_mi_final_exts       ()+          & set_mi_abi_hashes       ()           & set_mi_ext_fields       emptyExtensibleFields-          & set_mi_src_hash         (ms_hs_hash mod_summary)           & set_mi_hi_bytes         PartialIfaceBinHandle    where@@ -395,15 +404,11 @@      -- Desugar.addExportFlagsAndRules).  The mi_top_env field is used      -- by GHCi to decide whether the module has its full top-level      -- scope available. (#5534)-     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe IfaceTopEnv-     maybeGlobalRdrEnv rdr_env-        | backendWantsGlobalBindings (backend dflags)-        = Just $! let !exports = forceGlobalRdrEnv (globalRdrEnvLocal rdr_env)-                      !imports = mkIfaceImports import_decls-                  in IfaceTopEnv exports imports-          -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.-        | otherwise-        = Nothing+     mkIfaceTopEnv :: GlobalRdrEnv -> IfaceTopEnv+     mkIfaceTopEnv rdr_env+        = let !exports = sortAvails $ gresToAvailInfo $ globalRdrEnvElts $ globalRdrEnvLocal rdr_env+              !imports = mkIfaceImports import_decls+           in IfaceTopEnv exports imports       ifFamInstTcName = ifFamInstFam @@ -492,7 +497,9 @@  mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch mkIfaceCompleteMatch (CompleteMatch cls mtc) =-  IfaceCompleteMatch (uniqDSetToList cls) mtc+  -- NB: Sorting here means that COMPLETE {P, Q} and COMPLETE {Q, P} are+  -- considered identical, in particular for recompilation checking.+  IfaceCompleteMatch (sortBy stableNameCmp $ uniqDSetToList cls) mtc   {-@@ -514,9 +521,12 @@ mkIfaceImports :: [ImportUserSpec] -> [IfaceImport] mkIfaceImports = map go   where-    go (ImpUserSpec decl ImpUserAll) = IfaceImport decl ImpIfaceAll-    go (ImpUserSpec decl (ImpUserExplicit env)) = IfaceImport decl (ImpIfaceExplicit (forceGlobalRdrEnv env))-    go (ImpUserSpec decl (ImpUserEverythingBut ns)) = IfaceImport decl (ImpIfaceEverythingBut ns)+    go (ImpUserSpec decl ImpUserAll)+      = IfaceImport decl ImpIfaceAll+    go (ImpUserSpec decl (ImpUserExplicit env parents_of_implicits))+      = IfaceImport decl (ImpIfaceExplicit (sortAvails env) (nameSetElemsStable parents_of_implicits))+    go (ImpUserSpec decl (ImpUserEverythingBut ns))+      = IfaceImport decl (ImpIfaceEverythingBut (nameSetElemsStable ns))  mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical mkIfaceExports as = case sortAvails as of DefinitelyDeterministicAvails sas -> sas
compiler/GHC/Iface/Recomp.hs view
@@ -15,1647 +15,1990 @@    , CompileReason(..)    , recompileRequired    , addFingerprints-   )-where--import GHC.Prelude-import GHC.Data.FastString--import GHC.Driver.Backend-import GHC.Driver.Config.Finder-import GHC.Driver.Env-import GHC.Driver.DynFlags-import GHC.Driver.Ppr-import GHC.Driver.Plugins--import GHC.Iface.Syntax-import GHC.Iface.Recomp.Binary-import GHC.Iface.Load-import GHC.Iface.Recomp.Flags-import GHC.Iface.Env--import GHC.Core-import GHC.Tc.Utils.Monad-import GHC.Hs--import GHC.Data.Graph.Directed-import GHC.Data.Maybe--import GHC.Utils.Error-import GHC.Utils.Panic-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Misc as Utils-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-import GHC.Types.Name.Set-import GHC.Types.SrcLoc-import GHC.Types.Unique.Set-import GHC.Types.Fixity.Env-import GHC.Types.Unique.Map-import GHC.Unit.External-import GHC.Unit.Finder-import GHC.Unit.State-import GHC.Unit.Home-import GHC.Unit.Module-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.Warnings-import GHC.Unit.Module.Deps--import Control.Monad-import Data.List (sortBy, sort, sortOn)-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Word (Word64)-import Data.Either----Qualified import so we can define a Semigroup instance--- but it doesn't clash with Outputable.<>-import qualified Data.Semigroup-import GHC.List (uncons)-import Data.Ord-import Data.Containers.ListUtils-import Data.Bifunctor-import GHC.Iface.Errors.Ppr--{--  ------------------------------------------------          Recompilation checking-  -------------------------------------------------A complete description of how recompilation checking works can be-found in the wiki commentary:-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance--Please read the above page for a top-down description of how this all-works.  Notes below cover specific issues related to the implementation.--Basic idea:--  * In the mi_usages information in an interface, we record the-    fingerprint of each free variable of the module--  * In mkIface, we compute the fingerprint of each exported thing A.f.-    For each external thing that A.f refers to, we include the fingerprint-    of the external reference when computing the fingerprint of A.f.  So-    if anything that A.f depends on changes, then A.f's fingerprint will-    change.-    Also record any dependent files added with-      * addDependentFile-      * #include-      * -optP-include--  * In checkOldIface we compare the mi_usages for the module with-    the actual fingerprint for all each thing recorded in mi_usages--}--data RecompileRequired-  -- | everything is up to date, recompilation is not required-  = UpToDate-  -- | Need to compile the module-  | NeedsRecompile !CompileReason-   deriving (Eq)--needsRecompileBecause :: RecompReason -> RecompileRequired-needsRecompileBecause = NeedsRecompile . RecompBecause--data MaybeValidated a-  -- | The item contained is validated to be up to date-  = UpToDateItem a-  -- | The item is are absent altogether or out of date, for the reason given.-  | OutOfDateItem-      !CompileReason-      -- ^ the reason we need to recompile.-      (Maybe a)-      -- ^ The old item, if it exists-  deriving (Functor)--instance Outputable a => Outputable (MaybeValidated a) where-  ppr (UpToDateItem a) = text "UpToDate" <+> ppr a-  ppr (OutOfDateItem r _) = text "OutOfDate: " <+> ppr r--outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a-outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item--data CompileReason-  -- | The .hs file has been touched, or the .o/.hi file does not exist-  = MustCompile-  -- | The .o/.hi files are up to date, but something else has changed-  -- to force recompilation; the String says what (one-line summary)-  | RecompBecause !RecompReason-   deriving (Eq)--instance Outputable RecompileRequired where-  ppr UpToDate = text "UpToDate"-  ppr (NeedsRecompile reason) = ppr reason--instance Outputable CompileReason where-  ppr MustCompile = text "MustCompile"-  ppr (RecompBecause r) = text "RecompBecause" <+> ppr r--instance Semigroup RecompileRequired where-  UpToDate <> r = r-  mc <> _       = mc--instance Monoid RecompileRequired where-  mempty = UpToDate--data RecompReason-  = UnitDepRemoved UnitId-  | ModulePackageChanged FastString-  | SourceFileChanged-  | ThisUnitIdChanged-  | ImpurePlugin-  | PluginsChanged-  | PluginFingerprintChanged-  | ModuleInstChanged-  | HieMissing-  | HieOutdated-  | SigsMergeChanged-  | ModuleChanged ModuleName-  | ModuleRemoved (UnitId, ModuleName)-  | ModuleAdded (UnitId, ModuleName)-  | ModuleChangedRaw ModuleName-  | ModuleChangedIface ModuleName-  | FileChanged FilePath-  | CustomReason String-  | FlagsChanged-  | OptimFlagsChanged-  | HpcFlagsChanged-  | MissingBytecode-  | MissingObjectFile-  | MissingDynObjectFile-  | MissingDynHiFile-  | MismatchedDynHiFile-  | ObjectsChanged-  | LibraryChanged-  | THWithJS-  deriving (Eq)--instance Outputable RecompReason where-  ppr = \case-    UnitDepRemoved uid       -> ppr uid <+> text "removed"-    ModulePackageChanged s   -> ftext s <+> text "package changed"-    SourceFileChanged        -> text "Source file changed"-    ThisUnitIdChanged        -> text "-this-unit-id changed"-    ImpurePlugin             -> text "Impure plugin forced recompilation"-    PluginsChanged           -> text "Plugins changed"-    PluginFingerprintChanged -> text "Plugin fingerprint changed"-    ModuleInstChanged        -> text "Implementing module changed"-    HieMissing               -> text "HIE file is missing"-    HieOutdated              -> text "HIE file is out of date"-    SigsMergeChanged         -> text "Signatures to merge in changed"-    ModuleChanged m          -> ppr m <+> text "changed"-    ModuleChangedRaw m       -> ppr m <+> text "changed (raw)"-    ModuleChangedIface m     -> ppr m <+> text "changed (interface)"-    ModuleRemoved (_uid, m)   -> ppr m <+> text "removed"-    ModuleAdded (_uid, m)     -> ppr m <+> text "added"-    FileChanged fp           -> text fp <+> text "changed"-    CustomReason s           -> text s-    FlagsChanged             -> text "Flags changed"-    OptimFlagsChanged        -> text "Optimisation flags changed"-    HpcFlagsChanged          -> text "HPC flags changed"-    MissingBytecode          -> text "Missing bytecode"-    MissingObjectFile        -> text "Missing object file"-    MissingDynObjectFile     -> text "Missing dynamic object file"-    MissingDynHiFile         -> text "Missing dynamic interface file"-    MismatchedDynHiFile     -> text "Mismatched dynamic interface file"-    ObjectsChanged          -> text "Objects changed"-    LibraryChanged          -> text "Library changed"-    THWithJS                -> text "JS backend always recompiles modules using Template Haskell for now (#23013)"--recompileRequired :: RecompileRequired -> Bool-recompileRequired UpToDate = False-recompileRequired _ = True--recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired-recompThen ma mb = ma >>= \case-  UpToDate              -> mb-  rr@(NeedsRecompile _) -> pure rr--checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired-checkList = \case-  []               -> return UpToDate-  (check : checks) -> check `recompThen` checkList checks---------------------------- | Top level function to check if the version of an old interface file--- is equivalent to the current source file the user asked us to compile.--- If the same, we can avoid recompilation.------ We return on the outside whether the interface file is up to date, providing--- evidence that is with a `ModIface`. In the case that it isn't, we may also--- return a found or provided `ModIface`. Why we don't always return the old--- one, if it exists, is unclear to me, except that I tried it and some tests--- failed (see #18205).-checkOldIface-  :: HscEnv-  -> ModSummary-  -> Maybe ModIface         -- Old interface from compilation manager, if any-  -> IO (MaybeValidated ModIface)--checkOldIface hsc_env mod_summary maybe_iface-  = do  let dflags = hsc_dflags hsc_env-        let logger = hsc_logger hsc_env-        showPass logger $-            "Checking old interface for " ++-              (showPpr dflags $ ms_mod mod_summary) ++-              " (use -ddump-hi-diffs for more details)"-        initIfaceCheck (text "checkOldIface") hsc_env $-            check_old_iface hsc_env mod_summary maybe_iface--check_old_iface-  :: HscEnv-  -> ModSummary-  -> Maybe ModIface-  -> IfG (MaybeValidated ModIface)--check_old_iface hsc_env mod_summary maybe_iface-  = let dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env-        getIface =-            case maybe_iface of-                Just _  -> do-                    trace_if logger (text "We already have the old interface for" <+>-                      ppr (ms_mod mod_summary))-                    return maybe_iface-                Nothing -> loadIface dflags (msHiFilePath mod_summary)--        loadIface read_dflags iface_path = do-             let ncu        = hsc_NC hsc_env-             read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path-             case read_result of-                 Failed err -> do-                     let msg = readInterfaceErrorDiagnostic err-                     trace_if logger-                       $ vcat [ text "FYI: cannot read old interface file:"-                              , nest 4 msg ]-                     trace_hi_diffs logger $-                       vcat [ text "Old interface file was invalid:"-                            , nest 4 msg ]-                     return Nothing-                 Succeeded iface -> do-                     trace_if logger (text "Read the interface file" <+> text iface_path)-                     return $ Just iface-        check_dyn_hi :: ModIface-                  -> IfG (MaybeValidated ModIface)-                  -> IfG (MaybeValidated ModIface)-        check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do-          res <- recomp_check-          case res of-            UpToDateItem _ -> do-              maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary)-              case maybe_dyn_iface of-                Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing-                Just dyn_iface | mi_iface_hash (mi_final_exts dyn_iface)-                                    /= mi_iface_hash (mi_final_exts normal_iface)-                  -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing-                Just {} -> return res-            _ -> return res-        check_dyn_hi _ recomp_check = recomp_check---        src_changed-            | gopt Opt_ForceRecomp dflags    = True-            | otherwise = False-    in do-        when src_changed $-            liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off")--        case src_changed of-            -- If the source has changed and we're in interactive mode,-            -- avoid reading an interface; just return the one we might-            -- have been supplied with.-            True | not (backendWritesFiles $ backend dflags) ->-                return $ OutOfDateItem MustCompile maybe_iface--            -- Try and read the old interface for the current module-            -- from the .hi file left from the last time we compiled it-            True -> do-                maybe_iface' <- liftIO $ getIface-                return $ OutOfDateItem MustCompile maybe_iface'--            False -> do-                maybe_iface' <- liftIO $ getIface-                case maybe_iface' of-                    -- We can't retrieve the iface-                    Nothing    -> return $ OutOfDateItem MustCompile Nothing--                    -- We have got the old iface; check its versions-                    -- even in the SourceUnmodifiedAndStable case we-                    -- should check versions because some packages-                    -- might have changed or gone away.-                    Just iface ->-                      check_dyn_hi iface $ checkVersions hsc_env mod_summary iface---- | Check if a module is still the same 'version'.------ This function is called in the recompilation checker after we have--- determined that the module M being checked hasn't had any changes--- to its source file since we last compiled M. So at this point in general--- two things may have changed that mean we should recompile M:---   * The interface export by a dependency of M has changed.---   * The compiler flags specified this time for M have changed---     in a manner that is significant for recompilation.--- We return not just if we should recompile the object file but also--- if we should rebuild the interface file.-checkVersions :: HscEnv-              -> ModSummary-              -> ModIface       -- Old interface-              -> IfG (MaybeValidated ModIface)-checkVersions hsc_env mod_summary iface-  = do { liftIO $ trace_hi_diffs logger-                        (text "Considering whether compilation is required for" <+>-                        ppr (mi_module iface) <> colon)--       -- readIface will have verified that the UnitId matches,-       -- but we ALSO must make sure the instantiation matches up.  See-       -- test case bkpcabal04!-       ; hsc_env <- getTopEnv-       ; if mi_src_hash iface /= ms_hs_hash mod_summary-            then return $ outOfDateItemBecause SourceFileChanged Nothing else do {-       ; if not (isHomeModule home_unit (mi_module iface))-            then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do {-       ; recomp <- liftIO $ checkFlagHash hsc_env iface-                             `recompThen` checkOptimHash hsc_env iface-                             `recompThen` checkHpcHash hsc_env iface-                             `recompThen` checkMergedSignatures hsc_env mod_summary iface-                             `recompThen` checkHsig logger home_unit mod_summary iface-                             `recompThen` pure (checkHie dflags mod_summary)-       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {-       ; recomp <- checkDependencies hsc_env mod_summary iface-       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {-       ; recomp <- checkPlugins (hsc_plugins hsc_env) iface-       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {---       -- Source code unchanged and no errors yet... carry on-       ---       -- First put the dependent-module info, read from the old-       -- interface, into the envt, so that when we look for-       -- interfaces we look for the right one (.hi or .hi-boot)-       ---       -- 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).--       when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {-          ; updateEps_ $ \eps  -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }-       }-       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) u-                             | u <- mi_usages iface]-       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {-       ; return $ UpToDateItem iface-    }}}}}}}-  where-    logger = hsc_logger hsc_env-    dflags = hsc_dflags hsc_env-    home_unit = hsc_home_unit hsc_env------ | Check if any plugins are requesting recompilation-checkPlugins :: Plugins -> ModIface -> IfG RecompileRequired-checkPlugins plugins iface = liftIO $ do-  recomp <- recompPlugins plugins-  let new_fingerprint = fingerprintPluginRecompile recomp-  let old_fingerprint = mi_plugin_hash (mi_final_exts iface)-  return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp--recompPlugins :: Plugins -> IO PluginRecompile-recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins)--fingerprintPlugins :: Plugins -> IO Fingerprint-fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins--fingerprintPluginRecompile :: PluginRecompile -> Fingerprint-fingerprintPluginRecompile recomp = case recomp of-  NoForceRecompile  -> fingerprintString "NoForceRecompile"-  ForceRecompile    -> fingerprintString "ForceRecompile"-  -- is the chance of collision worth worrying about?-  -- An alternative is to fingerprintFingerprints [fingerprintString-  -- "maybeRecompile", fp]-  MaybeRecompile fp -> fp---pluginRecompileToRecompileRequired-    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired-pluginRecompileToRecompileRequired old_fp new_fp pr-  | old_fp == new_fp =-    case pr of-      NoForceRecompile  -> UpToDate--      -- we already checked the fingerprint above so a mismatch is not possible-      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.-      MaybeRecompile _  -> UpToDate--      -- when we have an impure plugin in the stack we have to unconditionally-      -- recompile since it might integrate all sorts of crazy IO results into-      -- its compilation output.-      ForceRecompile    -> needsRecompileBecause ImpurePlugin--  | old_fp `elem` magic_fingerprints ||-    new_fp `elem` magic_fingerprints-    -- The fingerprints do not match either the old or new one is a magic-    -- fingerprint. This happens when non-pure plugins are added for the first-    -- time or when we go from one recompilation strategy to another: (force ->-    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)-    ---    -- For example when we go from ForceRecomp to NoForceRecomp-    -- recompilation is triggered since the old impure plugins could have-    -- changed the build output which is now back to normal.-    = needsRecompileBecause PluginsChanged--  | otherwise =-    case pr of-      -- even though a plugin is forcing recompilation the fingerprint changed-      -- which would cause recompilation anyways so we report the fingerprint-      -- change instead.-      ForceRecompile   -> needsRecompileBecause PluginFingerprintChanged--      _                -> needsRecompileBecause PluginFingerprintChanged-- where-   magic_fingerprints =-       [ fingerprintString "NoForceRecompile"-       , fingerprintString "ForceRecompile"-       ]----- | Check if an hsig file needs recompilation because its--- implementing module has changed.-checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired-checkHsig logger home_unit 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)-    case inner_mod == mi_semantic_module iface of-        True -> up_to_date logger (text "implementing module unchanged")-        False -> return $ needsRecompileBecause ModuleInstChanged---- | Check if @.hie@ file is out of date or missing.-checkHie :: DynFlags -> ModSummary -> RecompileRequired-checkHie dflags mod_summary =-    let hie_date_opt = ms_hie_date mod_summary-        hi_date = ms_iface_date mod_summary-    in if not (gopt Opt_WriteHie dflags)-      then UpToDate-      else case (hie_date_opt, hi_date) of-             (Nothing, _) -> needsRecompileBecause HieMissing-             (Just hie_date, Just hi_date)-                 | hie_date < hi_date-                 -> needsRecompileBecause HieOutdated-             _ -> UpToDate---- | Check the flags haven't changed-checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired-checkFlagHash hsc_env iface = do-    let logger   = hsc_logger hsc_env-    let old_hash = mi_flag_hash (mi_final_exts iface)-    new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally-    case old_hash == new_hash of-        True  -> up_to_date logger (text "Module flags unchanged")-        False -> out_of_date_hash logger FlagsChanged-                     (text "  Module flags have changed")-                     old_hash new_hash---- | Check the optimisation flags haven't changed-checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired-checkOptimHash hsc_env iface = do-    let logger   = hsc_logger hsc_env-    let old_hash = mi_opt_hash (mi_final_exts iface)-    new_hash <- fingerprintOptFlags (hsc_dflags hsc_env)-                                               putNameLiterally-    if | old_hash == new_hash-         -> up_to_date logger (text "Optimisation flags unchanged")-       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)-         -> up_to_date logger (text "Optimisation flags changed; ignoring")-       | otherwise-         -> out_of_date_hash logger OptimFlagsChanged-                     (text "  Optimisation flags have changed")-                     old_hash new_hash---- | Check the HPC flags haven't changed-checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired-checkHpcHash hsc_env iface = do-    let logger   = hsc_logger hsc_env-    let old_hash = mi_hpc_hash (mi_final_exts iface)-    new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env)-                                               putNameLiterally-    if | old_hash == new_hash-         -> up_to_date logger (text "HPC flags unchanged")-       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)-         -> up_to_date logger (text "HPC flags changed; ignoring")-       | otherwise-         -> out_of_date_hash logger HpcFlagsChanged-                     (text "  HPC flags have changed")-                     old_hash new_hash---- Check that the set of signatures we are merging in match.--- If the -unit-id flags change, this can change too.-checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired-checkMergedSignatures hsc_env mod_summary iface = do-    let logger     = hsc_logger hsc_env-    let unit_state = hsc_units hsc_env-    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]-        new_merged = case lookupUniqMap (requirementContext unit_state)-                          (ms_mod_name mod_summary) of-                        Nothing -> []-                        Just r -> sort $ map (instModuleToModule unit_state) r-    if old_merged == new_merged-        then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged)-        else return $ needsRecompileBecause SigsMergeChanged---- If the direct imports of this module are resolved to targets that--- are not among the dependencies of the previous interface file,--- then we definitely need to recompile.  This catches cases like---   - an exposed package has been upgraded---   - we are compiling with different package flags---   - a home module that was shadowing a package module has been removed---   - a new home module has been added that shadows a package module--- See bug #1372.------ Returns (RecompBecause <reason>) if recompilation is required.-checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired-checkDependencies hsc_env summary iface- = do-    res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)-    res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)-    case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of-      Left recomp -> return $ NeedsRecompile recomp-      Right es -> do-        let (hs, ps) = partitionEithers es-        liftIO $-          check_mods (sort hs) prev_dep_mods-          `recompThen`-            let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd ps-            in check_packages allPkgDeps prev_dep_pkgs- where--   classify_import :: (ModuleName -> t -> IO FindResult)-                      -> [(t, GenLocated l ModuleName)]-                    -> IfG-                       [Either-                          CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]-   classify_import find_import imports =-    liftIO $ traverse (\(mb_pkg, L _ mod) ->-           let reason = ModuleChanged mod-           in classify reason <$> find_import mod mb_pkg)-           imports-   dflags        = hsc_dflags hsc_env-   fopts         = initFinderOpts dflags-   logger        = hsc_logger hsc_env-   fc            = hsc_FC hsc_env-   mhome_unit    = hsc_home_unit_maybe hsc_env-   all_home_units = hsc_all_home_unit_ids hsc_env-   units         = hsc_units hsc_env-   prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface)-   prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))-                                            (dep_plugin_pkgs (mi_deps iface)))--   -- GHC.Prim is very special and doesn't appear in ms_textual_imps but-   -- ghc-prim will appear in the package dependencies still. In order to not confuse-   -- the recompilation logic we need to not forget we imported GHC.Prim.-   fake_ghc_prim_import =  case mhome_unit of-                              Just home_unit-                                | homeUnitId home_unit == primUnitId-                                -> Left (primUnitId, mkModuleName "GHC.Prim")-                              _ -> Right (fsLit "GHC.Prim", primUnitId)---   classify _ (Found _ mod)-    | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod))-    | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod))-   classify reason _ = Left (RecompBecause reason)--   check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired-   check_mods [] [] = return UpToDate-   check_mods [] (old:_) = do-     -- This case can happen when a module is change from HPT to package import-     trace_hi_diffs logger $-      text "module no longer" <+> quotes (ppr old) <+>-        text "in dependencies"--     return $ needsRecompileBecause $ ModuleRemoved old-   check_mods (new:news) olds-    | Just (old, olds') <- uncons olds-    , new == old = check_mods (dropWhile (== new) news) olds'-    | otherwise = do-        trace_hi_diffs logger $-           text "imported module " <> quotes (ppr new) <>-           text " not among previous dependencies"-        return $ needsRecompileBecause $ ModuleAdded new--   check_packages :: [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired-   check_packages [] [] = return UpToDate-   check_packages [] (old:_) = do-     trace_hi_diffs logger $-      text "package " <> quotes (ppr old) <>-        text "no longer in dependencies"-     return $ needsRecompileBecause $ UnitDepRemoved old-   check_packages ((new_name, new_unit):news) olds-    | Just (old, olds') <- uncons olds-    , new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds'-    | otherwise = do-        trace_hi_diffs logger $-         text "imported package" <+> ftext new_name <+> ppr new_unit <+>-           text "not among previous dependencies"-        return $ needsRecompileBecause $ ModulePackageChanged new_name---needInterface :: Module -> (ModIface -> IO RecompileRequired)-             -> IfG RecompileRequired-needInterface mod continue-  = do-      mb_recomp <- tryGetModIface-        "need version info for"-        mod-      case mb_recomp of-        Nothing -> return $ NeedsRecompile MustCompile-        Just iface -> liftIO $ continue iface--tryGetModIface :: String -> Module -> IfG (Maybe ModIface)-tryGetModIface doc_msg mod-  = do  -- Load the imported interface if possible-    logger <- getLogger-    let doc_str = sep [text doc_msg, ppr mod]-    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod))--    mb_iface <- loadInterface doc_str mod ImportBySystem-        -- Load the interface, but don't complain on failure;-        -- Instead, get an Either back which we can test--    case mb_iface of-      Failed _ -> do-        liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod])-        return Nothing-                  -- Couldn't find or parse a module mentioned in the-                  -- old interface file.  Don't complain: it might-                  -- just be that the current module doesn't need that-                  -- import and it's been deleted-      Succeeded iface -> pure $ Just iface---- | Given the usage information extracted from the old--- M.hi file for the module being compiled, figure out--- whether M needs to be recompiled.-checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired-checkModUsage _ UsagePackageModule{-                                usg_mod = mod,-                                usg_mod_hash = old_mod_hash } = do-  logger <- getLogger-  needInterface mod $ \iface -> do-    let reason = ModuleChanged (moduleName mod)-    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))-        -- We only track the ABI hash of package modules, rather than-        -- individual entity usages, so if the ABI hash changes we must-        -- recompile.  This is safe but may entail more recompilation when-        -- a dependent package has changed.--checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do-  logger <- getLogger-  needInterface mod $ \iface -> do-    let reason = ModuleChangedRaw (moduleName mod)-    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))-checkModUsage _  UsageHomeModuleInterface{ usg_mod_name = mod_name-                                                 , usg_unit_id = uid-                                                 , usg_iface_hash = old_mod_hash } = do-  let mod = mkModule (RealUnit (Definite uid)) mod_name-  logger <- getLogger-  needInterface mod $ \iface -> do-    let reason = ModuleChangedIface mod_name-    checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface))--checkModUsage _ UsageHomeModule{-                                usg_mod_name = mod_name,-                                usg_unit_id  = uid,-                                usg_mod_hash = old_mod_hash,-                                usg_exports = maybe_old_export_hash,-                                usg_entities = old_decl_hash }-  = do-    let mod = mkModule (RealUnit (Definite uid)) mod_name-    logger <- getLogger-    needInterface mod $ \iface -> do-     let-         new_mod_hash    = mi_mod_hash (mi_final_exts iface)-         new_decl_hash   = mi_hash_fn  (mi_final_exts iface)-         new_export_hash = mi_exp_hash (mi_final_exts iface)--         reason = ModuleChanged (moduleName mod)--     liftIO $ do-           -- CHECK MODULE-       recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash-       if not (recompileRequired recompile)-         then return UpToDate-         else checkList-           [ -- CHECK EXPORT LIST-             checkMaybeHash logger reason maybe_old_export_hash new_export_hash-               (text "  Export list changed")-           , -- CHECK ITEMS ONE BY ONE-             checkList [ checkEntityUsage logger reason new_decl_hash u-                       | u <- old_decl_hash]-           , up_to_date logger (text "  Great!  The bits I use are up to date")-           ]--checkModUsage fc UsageFile{ usg_file_path = file,-                            usg_file_hash = old_hash,-                            usg_file_label = mlabel } =-  liftIO $-    handleIO handler $ do-      new_hash <- lookupFileCache fc $ unpackFS file-      if (old_hash /= new_hash)-         then return recomp-         else return UpToDate- where-   reason = FileChanged $ unpackFS file-   recomp  = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel-   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-  :: Logger-  -> RecompReason-  -> Fingerprint-  -> Fingerprint-  -> IO RecompileRequired-checkModuleFingerprint logger reason old_mod_hash new_mod_hash-  | new_mod_hash == old_mod_hash-  = up_to_date logger (text "Module fingerprint unchanged")--  | otherwise-  = out_of_date_hash logger reason (text "  Module fingerprint has changed")-                     old_mod_hash new_mod_hash--checkIfaceFingerprint-  :: Logger-  -> RecompReason-  -> Fingerprint-  -> Fingerprint-  -> IO RecompileRequired-checkIfaceFingerprint logger reason old_mod_hash new_mod_hash-  | new_mod_hash == old_mod_hash-  = up_to_date logger (text "Iface fingerprint unchanged")--  | otherwise-  = out_of_date_hash logger reason (text "  Iface fingerprint has changed")-                     old_mod_hash new_mod_hash---------------------------checkMaybeHash-  :: Logger-  -> RecompReason-  -> Maybe Fingerprint-  -> Fingerprint-  -> SDoc-  -> IO RecompileRequired-checkMaybeHash logger reason maybe_old_hash new_hash doc-  | Just hash <- maybe_old_hash, hash /= new_hash-  = out_of_date_hash logger reason doc hash new_hash-  | otherwise-  = return UpToDate---------------------------checkEntityUsage :: Logger-                 -> RecompReason-                 -> (OccName -> Maybe (OccName, Fingerprint))-                 -> (OccName, Fingerprint)-                 -> IO RecompileRequired-checkEntityUsage logger reason new_hash (name,old_hash) = do-  case new_hash name of-    -- We used it before, but it ain't there now-    Nothing       -> out_of_date logger reason (sep [text "No longer exported:", ppr name])-    -- It's there, but is it up to date?-    Just (_, new_hash)-      | new_hash == old_hash-      -> do trace_hi_diffs logger (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))-            return UpToDate-      | otherwise-      -> out_of_date_hash logger reason (text "  Out of date:" <+> ppr name) old_hash new_hash--up_to_date :: Logger -> SDoc -> IO RecompileRequired-up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate--out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired-out_of_date logger reason msg = trace_hi_diffs logger msg >> return (needsRecompileBecause reason)--out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired-out_of_date_hash logger reason msg old_hash new_hash-  = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])---- ------------------------------------------------------------------------------ Compute fingerprints for the interface--{--Note [Fingerprinting IfaceDecls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The general idea here is that we first examine the 'IfaceDecl's and determine-the recursive groups of them. We then walk these groups in dependency order,-serializing each contained 'IfaceDecl' to a "Binary" buffer which we then-hash using MD5 to produce a fingerprint for the group.--However, the serialization that we use is a bit funny: we override the @putName@-operation with our own which serializes the hash of a 'Name' instead of the-'Name' itself. This ensures that the fingerprint of a decl changes if anything-in its transitive closure changes. This trick is why we must be careful about-traversing in dependency order: we need to ensure that we have hashes for-everything referenced by the decl which we are fingerprinting.--Moreover, we need to be careful to distinguish between serialization of binding-Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls-field of a IfaceClsInst): only in the non-binding case should we include the-fingerprint; in the binding case we shouldn't since it is merely the name of the-thing that we are currently fingerprinting.---Note [Fingerprinting recursive groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The fingerprinting of a single recursive group is a rather subtle affair, as-seen in #18733.--How not to fingerprint-------------------------Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a-group in hash environment `hash_env0`:-- 1. extend hash_env0, giving each declaration in the group the fingerprint 0- 2. use this environment to hash the declarations' ABIs, resulting in-    group_fingerprint- 3. produce the final hash environment by extending hash_env0, mapping each-    declaration of the group to group_fingerprint--However, this is wrong. Consider, for instance, a program like:--    data A = ARecu B | ABase String deriving (Show)-    data B = BRecu A | BBase Int deriving (Show)--    info :: B-    info = BBase 1--A consequence of (3) is that A and B will have the same fingerprint. This means-that if the user changes `info` to:--    info :: A-    info = ABase "hello"--The program's ABI fingerprint will not change despite `info`'s type, and-therefore ABI, being clearly different.--However, the incorrectness doesn't end there: (1) means that all recursive-occurrences of names within the group will be given the same fingerprint. This-means that the group's fingerprint won't change if we change an occurrence of A-to B.--Surprisingly, this bug (#18733) lurked for many years before being uncovered.--How we now fingerprint-------------------------As seen above, the fingerprinting function must ensure that a groups-fingerprint captures the structure of within-group occurrences. The scheme that-we use is:-- 0. To ensure determinism, sort the declarations into a stable order by-    declaration name-- 1. Extend hash_env0, giving each declaration in the group a sequential-    fingerprint (e.g. 0, 1, 2, ...).-- 2. Use this environment to hash the declarations' ABIs, resulting in-    group_fingerprint.--    Since we included the sequence number in step (1) programs identical up to-    transposition of recursive occurrences are distinguishable, avoiding the-    second issue mentioned above.-- 3. Produce the final environment by extending hash_env, mapping each-    declaration of the group to the hash of (group_fingerprint, i), where-    i is the position of the declaration in the stable ordering.--    Including i in the hash ensures that the first issue noted above is-    avoided.---}---- | Add fingerprints for top-level declarations to a 'ModIface'.------ See Note [Fingerprinting IfaceDecls]-addFingerprints-        :: HscEnv-        -> PartialModIface-        -> IO ModIface-addFingerprints hsc_env iface0- = do-   eps <- hscEPS hsc_env-   let-       decls = mi_decls iface0-       decl_warn_fn = mkIfaceDeclWarnCache (fromIfaceWarnings $ mi_warns iface0)-       export_warn_fn = mkIfaceExportWarnCache (fromIfaceWarnings $ mi_warns iface0)-       fix_fn = mkIfaceFixCache (mi_fixities iface0)--        -- The ABI of a declaration represents everything that is made-        -- visible about the declaration that a client can depend on.-        -- see IfaceDeclABI below.-       declABI :: IfaceDecl -> IfaceDeclABI-       -- TODO: I'm not sure if this should be semantic_mod or this_mod.-       -- See also Note [Identity versus semantic module]-       declABI decl = (this_mod, decl, extras)-        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts-                                  non_orph_fis top_lvl_name_env decl--       -- This is used for looking up the Name of a default method-       -- from its OccName. See Note [default method Name]-       top_lvl_name_env =-         mkOccEnv [ (nameOccName nm, nm)-                  | IfaceId { ifName = nm } <- decls ]--       -- Dependency edges between declarations in the current module.-       -- This is computed by finding the free external names of each-       -- declaration, including IfaceDeclExtras (things that a-       -- declaration implicitly depends on).-       edges :: [ Node OccName IfaceDeclABI ]-       edges = [ DigraphNode abi (getOccName decl) out-               | decl <- decls-               , let abi = declABI decl-               , let out = localOccs $ freeNamesDeclABI abi-               ]--       name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n)-       localOccs =-         map (getParent . getOccName)-                        -- NB: names always use semantic module, so-                        -- filtering must be on the semantic module!-                        -- See Note [Identity versus semantic module]-                        . filter ((== semantic_mod) . name_module)-                        . nonDetEltsUniqSet-                   -- It's OK to use nonDetEltsUFM as localOccs is only-                   -- used to construct the edges and-                   -- stronglyConnCompFromEdgedVertices is deterministic-                   -- even with non-deterministic order of edges as-                   -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.-          where getParent :: OccName -> OccName-                getParent occ = lookupOccEnv parent_map occ `orElse` occ--        -- maps OccNames to their parents in the current module.-        -- e.g. a reference to a constructor must be turned into a reference-        -- to the TyCon for the purposes of calculating dependencies.-       parent_map :: OccEnv OccName-       parent_map = foldl' extend emptyOccEnv decls-          where extend env d =-                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]-                  where n = getOccName d--        -- Strongly-connected groups of declarations, in dependency order-       groups :: [SCC IfaceDeclABI]-       groups = stronglyConnCompFromEdgedVerticesOrd edges--       global_hash_fn = mkHashFun hsc_env eps--        -- How to output Names when generating the data to fingerprint.-        -- Here we want to output the fingerprint for each top-level-        -- Name, whether it comes from the current module or another-        -- module.  In this way, the fingerprint for a declaration will-        -- change if the fingerprint for anything it refers to (transitively)-        -- changes.-       mk_put_name :: OccEnv (OccName,Fingerprint)-                   -> WriteBinHandle -> Name -> IO  ()-       mk_put_name local_env bh name-          | isWiredInName name  =  putNameLiterally bh name-           -- wired-in names don't have fingerprints-          | otherwise-          = 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-                     -- and we know a backing impl for it.-                     -- See Note [Identity versus semantic module]-                     | semantic_mod /= this_mod-                     , not (isHoleModule semantic_mod) = global_hash_fn name-                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)-                           `orElse` pprPanic "urk! lookup local fingerprint"-                                       (ppr name $$ ppr local_env)))-                -- This panic indicates that we got the dependency-                -- analysis wrong, because we needed a fingerprint for-                -- an entity that wasn't in the environment.  To debug-                -- it, turn the panic into a trace, uncomment the-                -- pprTraces below, run the compile again, and inspect-                -- the output and the generated .hi file with-                -- --show-iface.-            in hash >>= put_ bh--        -- take a strongly-connected group of declarations and compute-        -- its fingerprint.--       fingerprint_group :: (OccEnv (OccName,Fingerprint),-                             [(Fingerprint,IfaceDecl)])-                         -> SCC IfaceDeclABI-                         -> IO (OccEnv (OccName,Fingerprint),-                                [(Fingerprint,IfaceDecl)])--       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)-          = do let hash_fn = mk_put_name local_env-                   decl = abiDecl abi-               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do-               hash <- computeFingerprint hash_fn abi-               env' <- extend_hash_env local_env (hash,decl)-               return (env', (hash,decl) : decls_w_hashes)--       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)-          = do let stable_abis = sortBy cmp_abiNames abis-                   stable_decls = map abiDecl stable_abis-               local_env1 <- foldM extend_hash_env local_env-                                   (zip (map mkRecFingerprint [0..]) stable_decls)-                -- See Note [Fingerprinting recursive groups]-               let hash_fn = mk_put_name local_env1-               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do-                -- put the cycle in a canonical order-               hash <- computeFingerprint hash_fn stable_abis-               let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls-                -- See Note [Fingerprinting recursive groups]-               local_env2 <- foldM extend_hash_env local_env pairs-               return (local_env2, pairs ++ decls_w_hashes)--       -- Make a fingerprint from the ordinal position of a binding in its group.-       mkRecFingerprint :: Word64 -> Fingerprint-       mkRecFingerprint i = Fingerprint 0 i--       bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint-       bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ]--       -- we have fingerprinted the whole declaration, but we now need-       -- to assign fingerprints to all the OccNames that it binds, to-       -- use when referencing those OccNames in later declarations.-       ---       extend_hash_env :: OccEnv (OccName,Fingerprint)-                       -> (Fingerprint,IfaceDecl)-                       -> IO (OccEnv (OccName,Fingerprint))-       extend_hash_env env0 (hash,d) =-          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0-                 (ifaceDeclFingerprints hash d))--   ---   (local_env, decls_w_hashes) <--       foldM fingerprint_group (emptyOccEnv, []) groups--   -- when calculating fingerprints, we always need to use canonical ordering-   -- for lists of things. The mi_deps has various lists of modules and-   -- suchlike, which are stored in canonical order:-   let sorted_deps :: Dependencies-       sorted_deps = mi_deps iface0--   -- The export hash of a module depends on the orphan hashes of the-   -- orphan modules below us in the dependency tree.  This is the way-   -- that changes in orphans get propagated all the way up the-   -- dependency tree.-   ---   -- Note [A bad dep_orphs optimization]-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   -- In a previous version of this code, we filtered out orphan modules which-   -- were not from the home package, justifying it by saying that "we'd-   -- pick up the ABI hashes of the external module instead".  This is wrong.-   -- Suppose that we have:-   ---   --       module External where-   --           instance Show (a -> b)-   ---   --       module Home1 where-   --           import External-   ---   --       module Home2 where-   --           import Home1-   ---   -- The export hash of Home1 needs to reflect the orphan instances of-   -- External. It's true that Home1 will get rebuilt if the orphans-   -- of External, but we also need to make sure Home2 gets rebuilt-   -- as well.  See #12733 for more details.-   let orph_mods-        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]-        $ dep_orphs sorted_deps-   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods--   -- Note [Do not update EPS with your own hi-boot]-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   -- (See also #10182).  When your hs-boot file includes an orphan-   -- instance declaration, you may find that the dep_orphs of a module you-   -- import contains reference to yourself.  DO NOT actually load this module-   -- or add it to the orphan hashes: you're going to provide the orphan-   -- instances yourself, no need to consult hs-boot; if you do load the-   -- interface into EPS, you will see a duplicate orphan instance.--   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,-                       mi_trust iface0)-                        -- Make sure change of Safe Haskell mode causes recomp.--   -- Note [Export hash depends on non-orphan family instances]-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   ---   -- Suppose we have:-   ---   --   module A where-   --       type instance F Int = Bool-   ---   --   module B where-   --       import A-   ---   --   module C where-   --       import B-   ---   -- The family instance consistency check for C depends on the dep_finsts of-   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need-   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of-   -- the exports of B, because C always considers them when checking-   -- consistency.-   ---   -- A full discussion is in #12723.-   ---   -- We do NOT need to hash dep_orphs, because this is implied by-   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,-   -- because there is no eager consistency check as there is with type families-   -- (also we didn't store it anywhere!)-   ----   -- put the declarations in a canonical order, sorted by OccName-   let sorted_decls :: [(Fingerprint, IfaceDecl)]-       sorted_decls = Map.elems $ Map.fromList $-                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]--       -- This key is safe because mi_extra_decls contains tidied things.-       getOcc (IfGblTopBndr b) = getOccName b-       getOcc (IfLclTopBndr fs _ _ details) =-        case details of-          IfRecSelId { ifRecSelFirstCon = first_con }-            -> mkRecFieldOccFS (getOccFS first_con) (ifLclNameFS fs)-          _ -> mkVarOccFS (ifLclNameFS fs)--       binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) ()-       binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs)--       sorted_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]-       sorted_extra_decls = sortOn binding_key <$> mi_extra_decls iface0--   -- the flag hash depends on:-   --   - (some of) dflags-   -- it returns two hashes, one that shouldn't change-   -- the abi hash and one that should-   flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally--   opt_hash <- fingerprintOptFlags dflags putNameLiterally--   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally--   plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)--   -- the ABI hash depends on:-   --   - decls-   --   - export list-   --   - orphans-   --   - deprecations-   --   - flag abi hash-   --   - foreign stubs and files-   mod_hash <- computeFingerprint putNameLiterally-                      (map fst sorted_decls,-                       export_hash,  -- includes orphan_hash-                       mi_warns iface0,-                       mi_foreign iface0)--   -- The interface hash depends on:-   --   - the ABI hash, plus-   --   - the source file hash,-   --   - the module level annotations,-   --   - usages-   --   - deps (home and external packages, dependent files)-   --   - hpc-   iface_hash <- computeFingerprint putNameLiterally-                      (mod_hash,-                       mi_src_hash iface0,-                       ann_fn (mkVarOccFS (fsLit "module")),  -- See mkIfaceAnnCache-                       mi_usages iface0,-                       sorted_deps,-                       mi_hpc iface0)--   let-    final_iface_exts = ModIfaceBackend-      { mi_iface_hash     = iface_hash-      , mi_mod_hash       = mod_hash-      , mi_flag_hash      = flag_hash-      , mi_opt_hash       = opt_hash-      , mi_hpc_hash       = hpc_hash-      , mi_plugin_hash    = plugin_hash-      , mi_orphan         = not (   all ifRuleAuto orph_rules-                                      -- See Note [Orphans and auto-generated rules]-                                 && null orph_insts-                                 && null orph_fis)-      , mi_finsts         = not (null (mi_fam_insts iface0))-      , mi_exp_hash       = export_hash-      , mi_orphan_hash    = orphan_hash-      , mi_decl_warn_fn   = decl_warn_fn-      , mi_export_warn_fn = export_warn_fn-      , mi_fix_fn         = fix_fn-      , mi_hash_fn        = lookupOccEnv local_env-      }-    final_iface = completePartialModIface iface0-                    sorted_decls sorted_extra_decls final_iface_exts-   ---   return final_iface--  where-    this_mod = mi_module iface0-    semantic_mod = mi_semantic_module iface0-    dflags = hsc_dflags hsc_env-    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)-    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)-    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)-    ann_fn = mkIfaceAnnCache (mi_anns iface0)---- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules--- (in particular, the orphan modules which are transitively imported by the--- current module).------ Q: Why do we need the hash at all, doesn't the list of transitively--- imported orphan modules suffice?------ A: If one of our transitive imports adds a new orphan instance, our--- export hash must change so that modules which import us rebuild.  If we just--- hashed the [Module], the hash would not change even when a new instance was--- added to a module that already had an orphan instance.------ Q: Why don't we just hash the orphan hashes of our direct dependencies?--- Why the full transitive closure?------ A: Suppose we have these modules:------      module A where---          instance Show (a -> b) where---      module B where---          import A -- **---      module C where---          import A---          import B------ Whether or not we add or remove the import to A in B affects the--- orphan hash of B.  But it shouldn't really affect the orphan hash--- of C.  If we hashed only direct dependencies, there would be no--- way to tell that the net effect was a wash, and we'd be forced--- to recompile C and everything else.-getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]-getOrphanHashes hsc_env mods = do-  let-    dflags     = hsc_dflags hsc_env-    ctx        = initSDocContext dflags defaultUserStyle-    get_orph_hash mod = do-          iface <- initIfaceLoad hsc_env . withIfaceErr ctx-                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem-          return (mi_orphan_hash (mi_final_exts iface))--  mapM get_orph_hash mods---{--************************************************************************-*                                                                      *-          The ABI of an IfaceDecl-*                                                                      *-************************************************************************--Note [The ABI of an IfaceDecl]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The ABI of a declaration consists of:--   (a) the full name of the identifier (inc. module and package,-       because these are used to construct the symbol name by which-       the identifier is known externally).--   (b) the declaration itself, as exposed to clients.  That is, the-       definition of an Id is included in the fingerprint only if-       it is made available as an unfolding in the interface.--   (c) the fixity of the identifier (if it exists)-   (d) for Ids: rules-   (e) for classes: instances, fixity & rules for methods-   (f) for datatypes: instances, fixity & rules for constrs--Items (c)-(f) are not stored in the IfaceDecl, but instead appear-elsewhere in the interface file.  But they are *fingerprinted* with-the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,-and fingerprinting that as part of the declaration.--}--type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)--data IfaceDeclExtras-  = IfaceIdExtras IfaceIdExtras--  | IfaceDataExtras-       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)-       [IfaceInstABI]           -- Local class and family instances of this tycon-                                -- See Note [Orphans] in GHC.Core.InstEnv-       [AnnPayload]             -- Annotations of the type itself-       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations--  | IfaceClassExtras-       (Maybe Fixity)           -- Fixity of the class itself (if it exists)-       [IfaceInstABI]           -- Local instances of this class *or*-                                --   of its associated data types-                                -- See Note [Orphans] in GHC.Core.InstEnv-       [AnnPayload]             -- Annotations of the type itself-       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations-       [IfExtName]              -- Default methods. If a module-                                -- mentions a class, then it can-                                -- instantiate the class and thereby-                                -- use the default methods, so we must-                                -- include these in the fingerprint of-                                -- a class.--  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]--  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]--  | IfaceOtherDeclExtras--data IfaceIdExtras-  = IdExtras-       (Maybe Fixity)           -- Fixity of the Id (if it exists)-       [IfaceRule]              -- Rules for the Id-       [AnnPayload]             -- Annotations for the Id---- When hashing a class or family instance, we hash only the--- DFunId or CoAxiom, because that depends on all the--- information about the instance.----type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance--abiDecl :: IfaceDeclABI -> IfaceDecl-abiDecl (_, decl, _) = decl--cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering-cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`-                         getOccName (abiDecl abi2)--freeNamesDeclABI :: IfaceDeclABI -> NameSet-freeNamesDeclABI (_mod, decl, extras) =-  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras--freeNamesDeclExtras :: IfaceDeclExtras -> NameSet-freeNamesDeclExtras (IfaceIdExtras id_extras)-  = freeNamesIdExtras id_extras-freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)-  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)-freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)-  = unionNameSets $-      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs-freeNamesDeclExtras (IfaceSynonymExtras _ _)-  = emptyNameSet-freeNamesDeclExtras (IfaceFamilyExtras _ insts _)-  = mkNameSet insts-freeNamesDeclExtras IfaceOtherDeclExtras-  = emptyNameSet--freeNamesIdExtras :: IfaceIdExtras -> NameSet-freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)--instance Outputable IfaceDeclExtras where-  ppr IfaceOtherDeclExtras       = Outputable.empty-  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras-  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]-  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]-  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,-                                                ppr_id_extras_s stuff]-  ppr (IfaceClassExtras fix insts anns stuff defms) =-    vcat [ppr fix, ppr_insts insts, ppr anns,-          ppr_id_extras_s stuff, ppr defms]--ppr_insts :: [IfaceInstABI] -> SDoc-ppr_insts _ = text "<insts>"--ppr_id_extras_s :: [IfaceIdExtras] -> SDoc-ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)--ppr_id_extras :: IfaceIdExtras -> SDoc-ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)---- This instance is used only to compute fingerprints-instance Binary IfaceDeclExtras where-  get _bh = panic "no get for IfaceDeclExtras"-  put_ bh (IfaceIdExtras extras) = do-   putByte bh 1; put_ bh extras-  put_ bh (IfaceDataExtras fix insts anns cons) = do-   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons-  put_ bh (IfaceClassExtras fix insts anns methods defms) = do-   putByte bh 3-   put_ bh fix-   put_ bh insts-   put_ bh anns-   put_ bh methods-   put_ bh defms-  put_ bh (IfaceSynonymExtras fix anns) = do-   putByte bh 4; put_ bh fix; put_ bh anns-  put_ bh (IfaceFamilyExtras fix finsts anns) = do-   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns-  put_ bh IfaceOtherDeclExtras = putByte bh 6--instance Binary IfaceIdExtras where-  get _bh = panic "no get for IfaceIdExtras"-  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }--declExtras :: (OccName -> Maybe Fixity)-           -> (OccName -> [AnnPayload])-           -> OccEnv [IfaceRule]-           -> OccEnv [IfaceClsInst]-           -> OccEnv [IfaceFamInst]-           -> OccEnv IfExtName          -- lookup default method names-           -> IfaceDecl-           -> IfaceDeclExtras--declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl-  = case decl of-      IfaceId{} -> IfaceIdExtras (id_extras n)-      IfaceData{ifCons=cons} ->-                     IfaceDataExtras (fix_fn n)-                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++-                         map ifDFun         (lookupOccEnvL inst_env n))-                        (ann_fn n)-                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))-      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->-                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms-          where-            insts = (map ifDFun $ (concatMap at_extras ats)-                                    ++ lookupOccEnvL inst_env n)-                           -- Include instances of the associated types-                           -- as well as instances of the class (#5147)-            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]-            -- Names of all the default methods (see Note [default method Name])-            defms = [ dmName-                    | IfaceClassOp bndr _ (Just _) <- sigs-                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)-                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]-      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)-                                           (ann_fn n)-      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)-                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))-                        (ann_fn n)-      _other -> IfaceOtherDeclExtras-  where-        n = getOccName decl-        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)-        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)---{- Note [default method Name] (see also #15970)-   ~~~~~~~~~~~~~~~~~~~~~~~~~~--The Names for the default methods aren't available in Iface syntax.--* We originally start with a DefMethInfo from the class, contain a-  Name for the default method--* We turn that into Iface syntax as a DefMethSpec which lacks a Name-  entirely. Why? Because the Name can be derived from the method name-  (in GHC.IfaceToCore), so doesn't need to be serialised into the interface-  file.--But now we have to get the Name back, because the class declaration's-fingerprint needs to depend on it (this was the bug in #15970).  This-is done in a slightly convoluted way:--* Then, in addFingerprints we build a map that maps OccNames to Names--* We pass that map to declExtras which laboriously looks up in the map-  (using the derived occurrence name) to recover the Name we have just-  thrown away.--}--lookupOccEnvL :: OccEnv [v] -> OccName -> [v]-lookupOccEnvL env k = lookupOccEnv env k `orElse` []--{---- for testing: use the md5sum command to generate fingerprints and--- compare the results against our built-in version.-  fp' <- oldMD5 dflags bh-  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')-               else return fp--oldMD5 dflags bh = do-  tmp <- newTempName dflags CurrentModule "bin"-  writeBinMem bh tmp-  tmp2 <- newTempName dflags CurrentModule "md5"-  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2-  r <- system cmd-  case r of-    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)-    ExitSuccess -> do-        hash_str <- readFile tmp2-        return $! readHexFingerprint hash_str--}--------------------------- mkOrphMap partitions instance decls or rules into---      (a) an OccEnv for ones that are not orphans,---          mapping the local OccName to a list of its decls---      (b) a list of orphan decls-mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl-          -> [decl]             -- Sorted into canonical order-          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;-                                --      each sublist in canonical order-              [decl])           -- Orphan decls; in canonical order-mkOrphMap get_key decls-  = foldl' go (emptyOccEnv, []) decls-  where-    go (non_orphs, orphs) d-        | NotOrphan occ <- get_key d-        = (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs)-        | otherwise = (non_orphs, d:orphs)---- -------------------------------------------------------------------------------- Look up parents and versions of Names---- This is like a global version of the mi_hash_fn field in each ModIface.--- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get--- the parent and version info.--mkHashFun-        :: HscEnv                       -- needed to look up versions-        -> ExternalPackageState         -- ditto-        -> (Name -> IO Fingerprint)-mkHashFun hsc_env eps name-  | isHoleModule orig_mod-  = lookup (mkHomeModule home_unit (moduleName orig_mod))-  | otherwise-  = lookup orig_mod-  where-      home_unit = hsc_home_unit hsc_env-      dflags = hsc_dflags hsc_env-      hpt = hsc_HUG hsc_env-      pit = eps_PIT eps-      ctx = initSDocContext dflags defaultUserStyle-      occ = nameOccName name-      orig_mod = nameModule name-      lookup mod = do-        massertPpr (isExternalName name) (ppr name)-        iface <- case lookupIfaceByModule hpt pit mod of-                  Just iface -> return iface-                  Nothing ->-                      -- This can occur when we're writing out ifaces for-                      -- requirements; we didn't do any /real/ typechecking-                      -- so there's no guarantee everything is loaded.-                      -- Kind of a heinous hack.-                      initIfaceLoad hsc_env . withIfaceErr ctx-                          $ withoutDynamicNow-                            -- If you try and load interfaces when dynamic-too-                            -- enabled then it attempts to load the dyn_hi and hi-                            -- interface files. Backpack doesn't really care about-                            -- dynamic object files as it isn't doing any code-                            -- generation so -dynamic-too is turned off.-                            -- Some tests fail without doing this (such as T16219),-                            -- but they fail because dyn_hi files are not found for-                            -- one of the dependencies (because they are deliberately turned off)-                            -- Why is this check turned off here? That is unclear but-                            -- just one of the many horrible hacks in the backpack-                            -- implementation.-                          $ loadInterface (text "lookupVers2") mod ImportBySystem-        return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`-                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))----- | Creates cached lookup for the 'mi_anns' field of ModIface--- Hackily, we use "module" as the OccName for any module-level annotations-mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]-mkIfaceAnnCache anns-  = \n -> lookupOccEnv env n `orElse` []-  where-    pair (IfaceAnnotation target value) =-      (case target of-          NamedTarget occn -> occn-          ModuleTarget _   -> mkVarOccFS (fsLit "module")-      , [value])-    -- flipping (++), so the first argument is always short-    env = mkOccEnv_C (flip (++)) (map pair anns)+   , mkSelfRecomp+   )+where++import GHC.Prelude+import GHC.Data.FastString++import GHC.Driver.Backend+import GHC.Driver.Env+import GHC.Driver.DynFlags+import GHC.Driver.Ppr+import GHC.Driver.Plugins+++import GHC.Iface.Syntax+import GHC.Iface.Recomp.Binary+import GHC.Iface.Recomp.Types+import GHC.Iface.Load+import GHC.Iface.Recomp.Flags+import GHC.Iface.Env++import GHC.Core+import GHC.Tc.Utils.Monad+import GHC.Hs++import GHC.Data.Graph.Directed+import GHC.Data.Maybe++import GHC.Utils.Error+import GHC.Utils.Panic+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Misc as Utils+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.Avail+import GHC.Types.Basic ( ImportLevel(..) )+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.SrcLoc+import GHC.Types.Unique.Set+import GHC.Types.Fixity.Env+import GHC.Types.Unique.Map+import GHC.Unit.External+import GHC.Unit.Finder+import GHC.Unit.State+import GHC.Unit.Home+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.Deps++import Control.Monad+import Control.Monad.Trans.State+import Data.List (sortBy, sort, sortOn)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Word (Word64)+import Data.Either++--Qualified import so we can define a Semigroup instance+-- but it doesn't clash with Outputable.<>+import qualified Data.Semigroup+import GHC.List (uncons)+import Data.Ord+import Data.Containers.ListUtils+import GHC.Iface.Errors.Ppr+import Data.Functor+import Data.Bifunctor (first)+import GHC.Types.PkgQual++{-+  -----------------------------------------------+          Recompilation checking+  -----------------------------------------------++A complete description of how recompilation checking works can be+found in the wiki commentary:++ https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance++Please read the above page for a top-down description of how this all+works.  Notes below cover specific issues related to the implementation.++Basic idea:++  * In the mi_usages information in an interface, we record the+    fingerprint of each free variable of the module++  * In mkIface, we compute the fingerprint of each exported thing A.f.+    For each external thing that A.f refers to, we include the fingerprint+    of the external reference when computing the fingerprint of A.f.  So+    if anything that A.f depends on changes, then A.f's fingerprint will+    change.+    Also record any dependent files added with+      * addDependentFile+      * #include+      * -optP-include++  * In checkOldIface we compare the mi_usages for the module with+    the actual fingerprint for all each thing recorded in mi_usages+-}++data RecompileRequired+  -- | everything is up to date, recompilation is not required+  = UpToDate+  -- | Need to compile the module+  | NeedsRecompile !CompileReason+   deriving (Eq)++needsRecompileBecause :: RecompReason -> RecompileRequired+needsRecompileBecause = NeedsRecompile . RecompBecause++data MaybeValidated a+  -- | The item contained is validated to be up to date+  = UpToDateItem a+  -- | The item is are absent altogether or out of date, for the reason given.+  | OutOfDateItem+      !CompileReason+      -- ^ the reason we need to recompile.+      (Maybe a)+      -- ^ The old item, if it exists+  deriving (Functor)++instance Outputable a => Outputable (MaybeValidated a) where+  ppr (UpToDateItem a) = text "UpToDate" <+> ppr a+  ppr (OutOfDateItem r _) = text "OutOfDate: " <+> ppr r++outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a+outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item++data CompileReason+  -- | The .hs file has been touched, or the .o/.hi file does not exist+  = MustCompile+  -- | The .o/.hi files are up to date, but something else has changed+  -- to force recompilation; the String says what (one-line summary)+  | RecompBecause !RecompReason+   deriving (Eq)++instance Outputable RecompileRequired where+  ppr UpToDate = text "UpToDate"+  ppr (NeedsRecompile reason) = ppr reason++instance Outputable CompileReason where+  ppr MustCompile = text "MustCompile"+  ppr (RecompBecause r) = text "RecompBecause" <+> ppr r++instance Semigroup RecompileRequired where+  UpToDate <> r = r+  mc <> _       = mc++instance Monoid RecompileRequired where+  mempty = UpToDate++data RecompReason+  = UnitDepRemoved (ImportLevel, UnitId)+  | ModulePackageChanged FastString+  | SourceFileChanged+  | NoSelfRecompInfo+  | ThisUnitIdChanged+  | ImpurePlugin+  | PluginsChanged+  | PluginFingerprintChanged+  | ModuleInstChanged+  | HieMissing+  | HieOutdated+  | SigsMergeChanged+  | ModuleChanged ModuleName+  | ModuleRemoved (ImportLevel, UnitId, ModuleName)+  | ModuleAdded (ImportLevel, UnitId, ModuleName)+  | ModuleChangedRaw ModuleName+  | ModuleChangedIface ModuleName+  | FileChanged FilePath+  | CustomReason String+  | FlagsChanged+  | LinkFlagsChanged+  | OptimFlagsChanged+  | HpcFlagsChanged+  | MissingBytecode+  | MissingObjectFile+  | MissingDynObjectFile+  | MissingDynHiFile+  | MismatchedDynHiFile+  | ObjectsChanged+  | LibraryChanged+  | THWithJS+  deriving (Eq)+++instance Outputable RecompReason where+  ppr = \case+    UnitDepRemoved (_lvl, uid) -> ppr uid <+> text "removed"+    ModulePackageChanged s   -> ftext s <+> text "package changed"+    SourceFileChanged        -> text "Source file changed"+    NoSelfRecompInfo         -> text "Old interface lacks recompilation info"+    ThisUnitIdChanged        -> text "-this-unit-id changed"+    ImpurePlugin             -> text "Impure plugin forced recompilation"+    PluginsChanged           -> text "Plugins changed"+    PluginFingerprintChanged -> text "Plugin fingerprint changed"+    ModuleInstChanged        -> text "Implementing module changed"+    HieMissing               -> text "HIE file is missing"+    HieOutdated              -> text "HIE file is out of date"+    SigsMergeChanged         -> text "Signatures to merge in changed"+    ModuleChanged m          -> ppr m <+> text "changed"+    ModuleChangedRaw m       -> ppr m <+> text "changed (raw)"+    ModuleChangedIface m     -> ppr m <+> text "changed (interface)"+    ModuleRemoved (_st, _uid, m)   -> ppr m <+> text "removed"+    ModuleAdded (_st, _uid, m)     -> ppr m <+> text "added"+    FileChanged fp           -> text fp <+> text "changed"+    CustomReason s           -> text s+    FlagsChanged             -> text "Flags changed"+    LinkFlagsChanged         -> text "Flags changed"+    OptimFlagsChanged        -> text "Optimisation flags changed"+    HpcFlagsChanged          -> text "HPC flags changed"+    MissingBytecode          -> text "Missing bytecode"+    MissingObjectFile        -> text "Missing object file"+    MissingDynObjectFile     -> text "Missing dynamic object file"+    MissingDynHiFile         -> text "Missing dynamic interface file"+    MismatchedDynHiFile     -> text "Mismatched dynamic interface file"+    ObjectsChanged          -> text "Objects changed"+    LibraryChanged          -> text "Library changed"+    THWithJS                -> text "JS backend always recompiles modules using Template Haskell for now (#23013)"++recompileRequired :: RecompileRequired -> Bool+recompileRequired UpToDate = False+recompileRequired _ = True++recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired+recompThen ma mb = ma >>= \case+  UpToDate              -> mb+  rr@(NeedsRecompile _) -> pure rr++checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired+checkList = \case+  []               -> return UpToDate+  (check : checks) -> check `recompThen` checkList checks++----------------------++-- | Top level function to check if the version of an old interface file+-- is equivalent to the current source file the user asked us to compile.+-- If the same, we can avoid recompilation.+--+-- We return on the outside whether the interface file is up to date, providing+-- evidence that is with a `ModIface`. In the case that it isn't, we may also+-- return a found or provided `ModIface`. Why we don't always return the old+-- one, if it exists, is unclear to me, except that I tried it and some tests+-- failed (see #18205).+checkOldIface+  :: HscEnv+  -> ModSummary+  -> Maybe ModIface         -- Old interface from compilation manager, if any+  -> IO (MaybeValidated ModIface)++checkOldIface hsc_env mod_summary maybe_iface+  = do  let dflags = hsc_dflags hsc_env+        let logger = hsc_logger hsc_env+        showPass logger $+            "Checking old interface for " +++              (showPpr dflags $ ms_mod mod_summary) +++              " (use -ddump-hi-diffs for more details)"+        initIfaceCheck (text "checkOldIface") hsc_env $+            check_old_iface hsc_env mod_summary maybe_iface++check_old_iface+  :: HscEnv+  -> ModSummary+  -> Maybe ModIface+  -> IfG (MaybeValidated ModIface)++check_old_iface hsc_env mod_summary maybe_iface+  = let dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+        getIface =+            case maybe_iface of+                Just {}  -> do+                    trace_if logger (text "We already have the old interface for" <+>+                      ppr (ms_mod mod_summary))+                    return maybe_iface+                Nothing -> loadIface dflags (msHiFilePath mod_summary)++        loadIface read_dflags iface_path = do+             let ncu        = hsc_NC hsc_env+             read_result <- readIface (hsc_hooks hsc_env) logger read_dflags ncu (ms_mod mod_summary) iface_path+             case read_result of+                 Failed err -> do+                     let msg = readInterfaceErrorDiagnostic err+                     trace_if logger+                       $ vcat [ text "FYI: cannot read old interface file:"+                              , nest 4 msg ]+                     trace_hi_diffs logger $+                       vcat [ text "Old interface file was invalid:"+                            , nest 4 msg ]+                     return Nothing+                 Succeeded iface -> do+                     trace_if logger (text "Read the interface file" <+> text iface_path)+                     return $ Just iface+        check_dyn_hi :: ModIface+                  -> IfG (MaybeValidated ModIface)+                  -> IfG (MaybeValidated ModIface)+        check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do+          res <- recomp_check+          case res of+            UpToDateItem _ -> do+              maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary)+              case maybe_dyn_iface of+                Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing+                Just dyn_iface | mi_iface_hash dyn_iface+                                    /= mi_iface_hash normal_iface+                  -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing+                Just {} -> return res+            _ -> return res+        check_dyn_hi _ recomp_check = recomp_check+++        src_changed+            | gopt Opt_ForceRecomp dflags    = True+            | otherwise = False+    in do+        when src_changed $+            liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off")++        case src_changed of+            -- If the source has changed and we're in interactive mode,+            -- avoid reading an interface; just return the one we might+            -- have been supplied with.+            True | not (backendWritesFiles $ backend dflags) ->+                return $ OutOfDateItem MustCompile maybe_iface++            -- Try and read the old interface for the current module+            -- from the .hi file left from the last time we compiled it+            True -> do+                maybe_iface' <- liftIO $ getIface+                return $ OutOfDateItem MustCompile maybe_iface'++            False -> do+                maybe_iface' <- liftIO $ getIface+                case maybe_iface' of+                    -- We can't retrieve the iface+                    Nothing    -> return $ OutOfDateItem MustCompile Nothing++                    -- We have got the old iface; check its versions+                    -- even in the SourceUnmodifiedAndStable case we+                    -- should check versions because some packages+                    -- might have changed or gone away.+                    Just iface ->+                      case mi_self_recomp_info iface of+                        Nothing -> return $ outOfDateItemBecause NoSelfRecompInfo Nothing+                        Just sr_info -> check_dyn_hi iface $ checkVersions hsc_env mod_summary iface sr_info++-- | Check if a module is still the same 'version'.+--+-- This function is called in the recompilation checker after we have+-- determined that the module M being checked hasn't had any changes+-- to its source file since we last compiled M. So at this point in general+-- two things may have changed that mean we should recompile M:+--   * The interface export by a dependency of M has changed.+--   * The compiler flags specified this time for M have changed+--     in a manner that is significant for recompilation.+-- We return not just if we should recompile the object file but also+-- if we should rebuild the interface file.+checkVersions :: HscEnv+              -> ModSummary+              -> ModIface       -- Old interface+              -> IfaceSelfRecomp+              -> IfG (MaybeValidated ModIface)+checkVersions hsc_env mod_summary iface self_recomp+  = do { liftIO $ trace_hi_diffs logger+                        (text "Considering whether compilation is required for" <+>+                        ppr (mi_module iface) <> colon)++       -- readIface will have verified that the UnitId matches,+       -- but we ALSO must make sure the instantiation matches up.  See+       -- test case bkpcabal04!+       ; hsc_env <- getTopEnv+       ; if mi_sr_src_hash self_recomp /= ms_hs_hash mod_summary+            then return $ outOfDateItemBecause SourceFileChanged Nothing else do {+       ; if not (isHomeModule home_unit (mi_module iface))+            then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do {+       ; recomp <- liftIO $ checkFlagHash hsc_env (mi_module iface) self_recomp+                             `recompThen` checkOptimHash hsc_env self_recomp+                             `recompThen` checkHpcHash hsc_env self_recomp+                             `recompThen` checkMergedSignatures hsc_env mod_summary self_recomp+                             `recompThen` checkHsig logger home_unit mod_summary iface+                             `recompThen` pure (checkHie dflags mod_summary)+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {+       ; recomp <- checkDependencies hsc_env mod_summary iface+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {+       ; recomp <- checkPlugins (hsc_plugins hsc_env) self_recomp+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {++       -- Source code unchanged and no errors yet... carry on+       --+       -- First put the dependent-module info, read from the old+       -- interface, into the envt, so that when we look for+       -- interfaces we look for the right one (.hi or .hi-boot)+       --+       -- 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).++       when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {+          ; updateEps_ $ \eps  -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }+       }+       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) u+                             | u <- mi_sr_usages self_recomp]+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {+       ; return $ UpToDateItem iface+    }}}}}}}+  where+    logger = hsc_logger hsc_env+    dflags = hsc_dflags hsc_env+    home_unit = hsc_home_unit hsc_env++++-- | Check if any plugins are requesting recompilation+checkPlugins :: Plugins -> IfaceSelfRecomp -> IfG RecompileRequired+checkPlugins plugins self_recomp = liftIO $ do+  recomp <- recompPlugins plugins+  let new_fingerprint = fingerprintPluginRecompile recomp+  let old_fingerprint = mi_sr_plugin_hash self_recomp+  return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp++recompPlugins :: Plugins -> IO PluginRecompile+recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins)++fingerprintPlugins :: Plugins -> IO Fingerprint+fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins++fingerprintPluginRecompile :: PluginRecompile -> Fingerprint+fingerprintPluginRecompile recomp = case recomp of+  NoForceRecompile  -> fingerprintString "NoForceRecompile"+  ForceRecompile    -> fingerprintString "ForceRecompile"+  -- is the chance of collision worth worrying about?+  -- An alternative is to fingerprintFingerprints [fingerprintString+  -- "maybeRecompile", fp]+  MaybeRecompile fp -> fp+++pluginRecompileToRecompileRequired+    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired+pluginRecompileToRecompileRequired old_fp new_fp pr+  | old_fp == new_fp =+    case pr of+      NoForceRecompile  -> UpToDate++      -- we already checked the fingerprint above so a mismatch is not possible+      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.+      MaybeRecompile _  -> UpToDate++      -- when we have an impure plugin in the stack we have to unconditionally+      -- recompile since it might integrate all sorts of crazy IO results into+      -- its compilation output.+      ForceRecompile    -> needsRecompileBecause ImpurePlugin++  | old_fp `elem` magic_fingerprints ||+    new_fp `elem` magic_fingerprints+    -- The fingerprints do not match either the old or new one is a magic+    -- fingerprint. This happens when non-pure plugins are added for the first+    -- time or when we go from one recompilation strategy to another: (force ->+    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)+    --+    -- For example when we go from ForceRecomp to NoForceRecomp+    -- recompilation is triggered since the old impure plugins could have+    -- changed the build output which is now back to normal.+    = needsRecompileBecause PluginsChanged++  | otherwise =+    case pr of+      -- even though a plugin is forcing recompilation the fingerprint changed+      -- which would cause recompilation anyways so we report the fingerprint+      -- change instead.+      ForceRecompile   -> needsRecompileBecause PluginFingerprintChanged++      _                -> needsRecompileBecause PluginFingerprintChanged++ where+   magic_fingerprints =+       [ fingerprintString "NoForceRecompile"+       , fingerprintString "ForceRecompile"+       ]+++-- | Check if an hsig file needs recompilation because its+-- implementing module has changed.+checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired+checkHsig logger home_unit 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)+    case inner_mod == mi_semantic_module iface of+        True -> up_to_date logger (text "implementing module unchanged")+        False -> return $ needsRecompileBecause ModuleInstChanged++-- | Check if @.hie@ file is out of date or missing.+checkHie :: DynFlags -> ModSummary -> RecompileRequired+checkHie dflags mod_summary =+    let hie_date_opt = ms_hie_date mod_summary+        hi_date = ms_iface_date mod_summary+    in if not (gopt Opt_WriteHie dflags)+      then UpToDate+      else case (hie_date_opt, hi_date) of+             (Nothing, _) -> needsRecompileBecause HieMissing+             (Just hie_date, Just hi_date)+                 | hie_date < hi_date+                 -> needsRecompileBecause HieOutdated+             _ -> UpToDate++-- | Check the flags haven't changed+checkFlagHash :: HscEnv -> Module -> IfaceSelfRecomp -> IO RecompileRequired+checkFlagHash hsc_env iface_mod self_recomp = do+    let logger   = hsc_logger hsc_env+    let FingerprintWithValue old_fp old_flags = mi_sr_flag_hash self_recomp+    let (new_fp, new_flags) = fingerprintDynFlags hsc_env iface_mod putNameLiterally+    if old_fp == new_fp+      then up_to_date logger (text "Module flags unchanged")+      else do+        -- Do not perform this computation unless -ddump-hi-diffs is on+        let diffs = case old_flags of+                      Nothing -> pure [missingExtraFlagInfo]+                      Just old_flags -> checkIfaceFlags old_flags new_flags+        out_of_date logger FlagsChanged (fmap vcat diffs)+++checkIfaceFlags :: IfaceDynFlags -> IfaceDynFlags -> IO [SDoc]+checkIfaceFlags (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14)+                (IfaceDynFlags b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14) =+  flip execStateT [] $ do+    check_one "main is" (ppr . fmap (fmap (text @SDoc))) a1 b1+    check_one_simple "safemode" a2 b2+    check_one_simple "lang"  a3 b3+    check_one_simple "exts" a4 b4+    check_one_simple "cpp option" a5 b5+    check_one_simple "js option" a6 b6+    check_one_simple "cmm option" a7 b7+    check_one "paths" (ppr . map (text @SDoc)) a8 b8+    check_one_simple "prof" a9 b9+    check_one_simple "ticky" a10 b10+    check_one_simple "codegen" a11 b11+    check_one_simple "fat iface" a12 b12+    check_one_simple "debug level" a13 b13+    check_one_simple "caller cc filter" a14 b14+  where+    diffSimple p a b = vcat [text "before:" <+> p a+                           , text "after:" <+> p b ]++    check_one_simple s a b = check_one s ppr a b++    check_one s p a b = do+      let a' = computeFingerprint putNameLiterally a+      let b' = computeFingerprint putNameLiterally b+      if a' == b' then pure () else modify (([ text s <+> text "flags changed"] ++ [diffSimple p a b]) ++)++-- | Check the optimisation flags haven't changed+checkOptimHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired+checkOptimHash hsc_env iface = do+    let logger   = hsc_logger hsc_env+    let old_hash = mi_sr_opt_hash iface+    let !new_hash = fingerprintOptFlags (hsc_dflags hsc_env)+                                               putNameLiterally+    if | old_hash == new_hash+         -> up_to_date logger (text "Optimisation flags unchanged")+       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)+         -> up_to_date logger (text "Optimisation flags changed; ignoring")+       | otherwise+         -> out_of_date_hash logger OptimFlagsChanged+                     (text "  Optimisation flags have changed")+                     old_hash new_hash++-- | Check the HPC flags haven't changed+checkHpcHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired+checkHpcHash hsc_env self_recomp = do+    let logger   = hsc_logger hsc_env+    let old_hash = mi_sr_hpc_hash self_recomp+    let !new_hash = fingerprintHpcFlags (hsc_dflags hsc_env)+                                               putNameLiterally+    if | old_hash == new_hash+         -> up_to_date logger (text "HPC flags unchanged")+       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)+         -> up_to_date logger (text "HPC flags changed; ignoring")+       | otherwise+         -> out_of_date_hash logger HpcFlagsChanged+                     (text "  HPC flags have changed")+                     old_hash new_hash++-- Check that the set of signatures we are merging in match.+-- If the -unit-id flags change, this can change too.+checkMergedSignatures :: HscEnv -> ModSummary -> IfaceSelfRecomp -> IO RecompileRequired+checkMergedSignatures hsc_env mod_summary self_recomp = do+    let logger     = hsc_logger hsc_env+    let unit_state = hsc_units hsc_env+    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_sr_usages self_recomp ]+        new_merged = case lookupUniqMap (requirementContext unit_state)+                          (ms_mod_name mod_summary) of+                        Nothing -> []+                        Just r -> sort $ map (instModuleToModule unit_state) r+    if old_merged == new_merged+        then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged)+        else return $ needsRecompileBecause SigsMergeChanged++-- If the direct imports of this module are resolved to targets that+-- are not among the dependencies of the previous interface file,+-- then we definitely need to recompile.  This catches cases like+--   - an exposed package has been upgraded+--   - we are compiling with different package flags+--   - a home module that was shadowing a package module has been removed+--   - a new home module has been added that shadows a package module+-- See bug #1372.+--+-- Returns (RecompBecause <reason>) if recompilation is required.+checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired+checkDependencies hsc_env summary iface+ = do+    res_normal <- classify_import (findImportedModule hsc_env)+                                  ([(st, p, m) | (st, p, m) <- (ms_textual_imps summary)]+                                  +++                                  [(NormalLevel, NoPkgQual, m) | m <- ms_srcimps summary ])+    res_plugin <- classify_import (\mod _ -> findPluginModule hsc_env mod)+                    [(st, p, m) | (st, p, m) <- (ms_plugin_imps summary) ]+    case sequence (res_normal ++ res_plugin) of+      Left recomp -> return $ NeedsRecompile recomp+      Right es -> do+        let (hs, ps) = partitionEithers es+        liftIO $+          check_mods (sort hs) prev_dep_mods+          `recompThen`+            let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd ps+            in check_packages allPkgDeps prev_dep_pkgs+ where++   classify_import :: (ModuleName -> t -> IO FindResult)+                      -> [(ImportLevel, t, GenLocated l ModuleName)]+                    -> IfG+                       [Either+                          CompileReason (Either (ImportLevel, UnitId, ModuleName) (FastString, (ImportLevel, UnitId)))]+   classify_import find_import imports =+    liftIO $ traverse (\(st, mb_pkg, L _ mod) ->+           let reason = ModuleChanged mod+           in classify st reason <$> find_import mod mb_pkg)+           imports+   logger        = hsc_logger hsc_env+   all_home_units = hsc_all_home_unit_ids hsc_env+   prev_dep_mods = map (\(IfaceImportLevel s,u, a) -> (s, u, gwib_mod a)) $ Set.toAscList $ dep_direct_mods (mi_deps iface)+   prev_dep_pkgs = Set.toAscList (Set.union (Set.map (first tcImportLevel) (dep_direct_pkgs (mi_deps iface)))+                                            (Set.map ((SpliceLevel),) (dep_plugin_pkgs (mi_deps iface))))++   classify st _ (Found _ mod)+    | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((st, toUnitId $ moduleUnit mod, moduleName mod)))+    | otherwise = Right (Right (moduleNameFS (moduleName mod), (st, toUnitId $ moduleUnit mod)))+   classify _ reason _ = Left (RecompBecause reason)++   check_mods :: [(ImportLevel, UnitId, ModuleName)] -> [(ImportLevel, UnitId, ModuleName)] -> IO RecompileRequired+   check_mods [] [] = return UpToDate+   check_mods [] (old:_) = do+     -- This case can happen when a module is change from HPT to package import+     trace_hi_diffs logger $+      text "module no longer" <+> quotes (ppr old) <+>+        text "in dependencies"++     return $ needsRecompileBecause $ ModuleRemoved old+   check_mods (new:news) olds+    | Just (old, olds') <- uncons olds+    , new == old = check_mods (dropWhile (== new) news) olds'+    | otherwise = do+        trace_hi_diffs logger $+           text "imported module " <> quotes (ppr new) <>+           text " not among previous dependencies"+        return $ needsRecompileBecause $ ModuleAdded new++   check_packages :: [(FastString, (ImportLevel, UnitId))] -> [(ImportLevel, UnitId)] -> IO RecompileRequired+   check_packages [] [] = return UpToDate+   check_packages [] (old:_) = do+     trace_hi_diffs logger $+      text "package " <> quotes (ppr old) <>+        text "no longer in dependencies"+     return $ needsRecompileBecause $ UnitDepRemoved old+   check_packages ((new_name, (new_unit)):news) olds+    | Just (old, olds') <- uncons olds+    , new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds'+    | otherwise = do+        trace_hi_diffs logger $+         text "imported package" <+> ftext new_name <+> ppr new_unit <+>+           text "not among previous dependencies"+        return $ needsRecompileBecause $ ModulePackageChanged new_name+++needInterface :: Module -> (ModIface -> IO RecompileRequired)+             -> IfG RecompileRequired+needInterface mod continue+  = do+      mb_recomp <- tryGetModIface+        "need version info for"+        mod+      case mb_recomp of+        Nothing -> return $ NeedsRecompile MustCompile+        Just iface -> liftIO $ continue iface++tryGetModIface :: String -> Module -> IfG (Maybe ModIface)+tryGetModIface doc_msg mod+  = do  -- Load the imported interface if possible+    logger <- getLogger+    let doc_str = sep [text doc_msg, ppr mod]+    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod))++    mb_iface <- loadInterface doc_str mod ImportBySystem+        -- Load the interface, but don't complain on failure;+        -- Instead, get an Either back which we can test++    case mb_iface of+      Failed _ -> do+        liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod])+        return Nothing+                  -- Couldn't find or parse a module mentioned in the+                  -- old interface file.  Don't complain: it might+                  -- just be that the current module doesn't need that+                  -- import and it's been deleted+      Succeeded iface -> pure $ Just iface++-- | Given the usage information extracted from the old+-- M.hi file for the module being compiled, figure out+-- whether M needs to be recompiled.+checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired+checkModUsage _ UsagePackageModule{+                                usg_mod = mod,+                                usg_mod_hash = old_mod_hash } = do+  logger <- getLogger+  needInterface mod $ \iface -> do+    let reason = ModuleChanged (moduleName mod)+    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface)+        -- We only track the ABI hash of package modules, rather than+        -- individual entity usages, so if the ABI hash changes we must+        -- recompile.  This is safe but may entail more recompilation when+        -- a dependent package has changed.++checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do+  logger <- getLogger+  needInterface mod $ \iface -> do+    let reason = ModuleChangedRaw (moduleName mod)+    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface)+checkModUsage _  UsageHomeModuleInterface{ usg_mod_name = mod_name+                                                 , usg_unit_id = uid+                                                 , usg_iface_hash = old_mod_hash } = do+  let mod = mkModule (RealUnit (Definite uid)) mod_name+  logger <- getLogger+  needInterface mod $ \iface -> do+    let reason = ModuleChangedIface mod_name+    checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash iface)++checkModUsage _ UsageHomeModule{+                                usg_mod_name = mod_name,+                                usg_unit_id  = uid,+                                usg_mod_hash = old_mod_hash,+                                usg_exports  = maybe_imported_exports,+                                usg_entities = old_decl_hash }+  = do+    let mod = mkModule (RealUnit (Definite uid)) mod_name+    logger <- getLogger+    needInterface mod $ \iface -> do+     let+         new_mod_hash    = mi_mod_hash iface+         new_decl_hash   = mi_hash_fn  iface+         reason = ModuleChanged (moduleName mod)++     liftIO $ do+           -- CHECK MODULE+       recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash+       if not (recompileRequired recompile)+         then return UpToDate+         else checkList+           [ -- CHECK EXPORT LIST; see Note [When to recompile when export lists change?]+             checkHomeModImport logger reason maybe_imported_exports iface+           , -- CHECK USED ITEMS ONE BY ONE+             checkList [ checkEntityUsage logger reason new_decl_hash u+                       | u <- old_decl_hash]+           , up_to_date logger (text "  Great!  The bits I use are up to date")+           ]++checkModUsage fc UsageFile{ usg_file_path = file,+                            usg_file_hash = old_hash,+                            usg_file_label = mlabel } =+  liftIO $+    handleIO handler $ do+      new_hash <- lookupFileCache fc $ unpackFS file+      if (old_hash /= new_hash)+         then return recomp+         else return UpToDate+ where+   reason = FileChanged $ unpackFS file+   recomp  = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel+   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++-- | We are importing a module whose exports have changed.+-- Does this require recompilation?+--+-- See Note [When to recompile when export lists change?]+checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> ModIface -> IO RecompileRequired+checkHomeModImport _ _ Nothing _ = return UpToDate+checkHomeModImport logger reason+  (Just (HomeModImport old_orphan_like_hash old_avails))+  iface+    -- (1) Orphans (of the module we are importing or of its dependencies)+    --     have changed: recompilation is required.+    --+    -- See Note [Orphan-like hash].+    | old_orphan_like_hash /= new_orphan_like_hash+    = out_of_date_hash logger reason (text "  Orphan-likes changed")+        old_orphan_like_hash new_orphan_like_hash+    | otherwise+    -- (2) Is there a change in the set of entities we are importing?+    = case old_avails of+        -- (a) Whole module import: recompile if the export hash+        -- of the module we are importing has changed.+        HMIA_Implicit old_avails_hash+          | old_avails_hash /= new_avails_hash+          -> out_of_date_hash logger reason (text "  Export list changed")+               old_orphan_like_hash new_orphan_like_hash+          | otherwise+          -> return UpToDate+        -- (b) Explicit imports: recompile if there is a change in the+        --     set of imported items.+        HMIA_Explicit+         { hmia_imported_avails        = DetOrdAvails imps+         , hmia_parents_with_implicits = parents_of_implicits+         } ->+          case checkNewExportedAvails new_exports parents_of_implicits imps of+            [] -> return UpToDate+            changes@(_:_) ->+              do trace_hi_diffs logger $+                   hang (text "Export list changed")+                      2 (ppr changes)+                 return $ needsRecompileBecause reason+  where+    new_orphan_like_hash = mi_orphan_like_hash iface+    new_avails_hash      = mi_export_avails_hash iface+    new_exports          = mi_exports iface++-- | The exported avails of a module have changed. Should this cause recompilation+-- of a module that imports it?+--+-- This is only about export/import lists; checking for changes in the definitions+-- of used identifiers is done later (see 'checkEntityUsage').+--+-- See Note [When to recompile when export lists change?].+checkNewExportedAvails :: [AvailInfo] -> NameSet -> [AvailInfo] -> [AvailInfo]+checkNewExportedAvails new_avails parents_of_implicits imported_avails+  = concatMap go imported_avails+  where+    go a@(Avail n) =+      case lookupNameEnv env n of+        Nothing -> [a]+        Just {} -> []+    go a@(AvailTC n ns) =+      case lookupNameEnv env n of+        Nothing -> [a]+        Just a' ->+          case a' of+            Avail {} -> [a]+            AvailTC _ ns'+              | n `elemNameSet` parents_of_implicits+              ->+                -- We are dealing with an export item of the form @T(..)@.+                -- If the set of subordinate names has changed at all, we must+                -- recompile.+                if mkNameSet ns == mkNameSet ns'+                then []+                else [a]+              | otherwise+              ->+                -- We are dealing with an import item of the form @T(K,x,y)@.+                -- Just check that all the names we are explicitly importing+                -- continue to be exported. It's OK if T has more children+                -- than it used to.+                if all (`elem` ns') ns+                then []+                else [a]++    env = availsToNameEnv new_avails++{- Note [When to recompile when export lists change?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose module N imports module M, and the exports of M change. Does this+require recompiling N?++Suppose for example that we have:++  module M (foo) where+    foo = 3++  module N where+    import M+    bar = foo + 1+    baz = 2 * bar++If we add an identifier to the export list of M, we must recompile N because+this might introduce name clashes, e.g. changing M to:++  module M (foo, bar) where+    foo = 3+    bar = 7++will cause N to no longer compile because of a name clash involving 'bar'.++However, if N had an explicit import list:++  module N where+    import M(foo)+    bar = foo + 1+    baz = 2 * bar++then it *does not matter* that 'M' starts exporting 'bar'; 'N' is unaffected.++This justifies the following approach for deciding whether a change in exports+should lead to recompilation.++  (1) If the orphan instances exported by M change, or if the orphans of+      dependencies of M change, we must recompile N.+      See Note [Orphan-like hash]++  (2) Otherwise, look at all the import declarations that import M.++      (a) If there is a whole module import, or an "import hiding" import,+          then we must recompile N when the avails exported from M change+          (such a change is detected by using the 'mi_export_avails_hash').++      (b) Otherwise, all imports are explicit imports, but not every identifier+          is necessarily explicitly imported, as we might have an import of+          the form @import M(T(..))@.++          We proceed by comparing what we are importing from M against the+          new exports of M. We recompile unless the following two conditions+          are both satisfied:++            C1. Every explicitly imported identifier continues to be exported.+            C2. For every parent P in an import item of the form @P(..)@,+                the set of subordinates exported by P has not changed.++Note that this import check is done purely on the basis of the Names involved,+unlike the subsequent recompilation check done in 'checkEntityUsage' which+checks that the definitions of used identifiers have not changed.++Note [Orphan-like hash]+~~~~~~~~~~~~~~~~~~~~~~~+The orphan-like hash extends the orphan hash to include other entities that+also cause recompilation downstream upon changing.++The hash includes:++  (1) orphan class and family instances+  (2) exported named defaults (these are very similar to orphan instances)+  (3) non-orphan type family instances, including those of dependencies+  (4) the Safe Haskell safety of the module++Why do we need to do this? For (3), suppose we have:++  module A where+      type instance F Int = Bool++  module B where+      import A++  module C where+      import B++The family instance consistency check for C depends on the dep_finsts of+B.  If we rename module A to A2, when the dep_finsts of B changes, we need+to make sure that C gets rebuilt. Effectively, the dep_finsts are part of+the exports of B, because C always considers them when checking+consistency.++A full discussion is in #12723.++We do NOT need to hash dep_orphs, because this is implied by+dep_orphan_hashes, and we do not need to hash ordinary (non-orphan) class+instances, because there is no eager consistency check as there is with type+families. For this reason, we don't currently store a hash of non-orphan class+instances.+-}++------------------------+checkModuleFingerprint+  :: Logger+  -> RecompReason+  -> Fingerprint+  -> Fingerprint+  -> IO RecompileRequired+checkModuleFingerprint logger reason old_mod_hash new_mod_hash+  | new_mod_hash == old_mod_hash+  = up_to_date logger (text "Module fingerprint unchanged")++  | otherwise+  = out_of_date_hash logger reason (text "  Module fingerprint has changed")+                     old_mod_hash new_mod_hash++checkIfaceFingerprint+  :: Logger+  -> RecompReason+  -> Fingerprint+  -> Fingerprint+  -> IO RecompileRequired+checkIfaceFingerprint logger reason old_mod_hash new_mod_hash+  | new_mod_hash == old_mod_hash+  = up_to_date logger (text "Iface fingerprint unchanged")++  | otherwise+  = out_of_date_hash logger reason (text "  Iface fingerprint has changed")+                     old_mod_hash new_mod_hash++------------------------+checkEntityUsage :: Logger+                 -> RecompReason+                 -> (OccName -> Maybe (OccName, Fingerprint))+                 -> (OccName, Fingerprint)+                 -> IO RecompileRequired+checkEntityUsage logger reason new_hash (name,old_hash) = do+  case new_hash name of+    -- We used it before, but it ain't there now+    Nothing       -> out_of_date logger reason (pure $ sep [text "No longer exported:", ppr name])+    -- It's there, but is it up to date?+    Just (_, new_hash)+      | new_hash == old_hash+      -> do trace_hi_diffs logger (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))+            return UpToDate+      | otherwise+      -> out_of_date_hash logger reason (text "  Out of date:" <+> ppr name) old_hash new_hash++up_to_date :: Logger -> SDoc -> IO RecompileRequired+up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate++out_of_date :: Logger -> RecompReason -> IO SDoc -> IO RecompileRequired+out_of_date logger reason msg = trace_hi_diffs_io logger msg >> return (needsRecompileBecause reason)++out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired+out_of_date_hash logger reason msg old_hash new_hash+  = out_of_date logger reason (pure $ hsep [msg, ppr old_hash, text "->", ppr new_hash])++-- ---------------------------------------------------------------------------+-- Compute fingerprints for the interface++{- Note [Fingerprinting IfaceDecls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The general idea here is that we first examine the 'IfaceDecl's and determine+the recursive groups of them. We then walk these groups in dependency order,+serializing each contained 'IfaceDecl' to a "Binary" buffer which we then+hash using MD5 to produce a fingerprint for the group.++However, the serialization that we use is a bit funny: we override the @putName@+operation with our own which serializes the hash of a 'Name' instead of the+'Name' itself. This ensures that the fingerprint of a decl changes if anything+in its transitive closure changes. This trick is why we must be careful about+traversing in dependency order: we need to ensure that we have hashes for+everything referenced by the decl which we are fingerprinting.++Moreover, we need to be careful to distinguish between serialization of binding+Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls+field of a IfaceClsInst): only in the non-binding case should we include the+fingerprint; in the binding case we shouldn't since it is merely the name of the+thing that we are currently fingerprinting.+++Note [Fingerprinting recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The fingerprinting of a single recursive group is a rather subtle affair, as+seen in #18733.++How not to fingerprint+----------------------++Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a+group in hash environment `hash_env0`:++ 1. extend hash_env0, giving each declaration in the group the fingerprint 0+ 2. use this environment to hash the declarations' ABIs, resulting in+    group_fingerprint+ 3. produce the final hash environment by extending hash_env0, mapping each+    declaration of the group to group_fingerprint++However, this is wrong. Consider, for instance, a program like:++    data A = ARecu B | ABase String deriving (Show)+    data B = BRecu A | BBase Int deriving (Show)++    info :: B+    info = BBase 1++A consequence of (3) is that A and B will have the same fingerprint. This means+that if the user changes `info` to:++    info :: A+    info = ABase "hello"++The program's ABI fingerprint will not change despite `info`'s type, and+therefore ABI, being clearly different.++However, the incorrectness doesn't end there: (1) means that all recursive+occurrences of names within the group will be given the same fingerprint. This+means that the group's fingerprint won't change if we change an occurrence of A+to B.++Surprisingly, this bug (#18733) lurked for many years before being uncovered.++How we now fingerprint+----------------------++As seen above, the fingerprinting function must ensure that a groups+fingerprint captures the structure of within-group occurrences. The scheme that+we use is:++ 0. To ensure determinism, sort the declarations into a stable order by+    declaration name++ 1. Extend hash_env0, giving each declaration in the group a sequential+    fingerprint (e.g. 0, 1, 2, ...).++ 2. Use this environment to hash the declarations' ABIs, resulting in+    group_fingerprint.++    Since we included the sequence number in step (1) programs identical up to+    transposition of recursive occurrences are distinguishable, avoiding the+    second issue mentioned above.++ 3. Produce the final environment by extending hash_env, mapping each+    declaration of the group to the hash of (group_fingerprint, i), where+    i is the position of the declaration in the stable ordering.++    Including i in the hash ensures that the first issue noted above is+    avoided.++-}++-- | Compute the information needed for self-recompilation checking. This+-- information can be computed before the backend phase.+mkSelfRecomp :: HscEnv -> Module -> Fingerprint -> [Usage] -> IO IfaceSelfRecomp+mkSelfRecomp hsc_env this_mod src_hash usages = do+      let dflags = hsc_dflags hsc_env++      let dyn_flags_info = fingerprintDynFlags hsc_env this_mod putNameLiterally++      let opt_hash = fingerprintOptFlags dflags putNameLiterally++      let hpc_hash = fingerprintHpcFlags dflags putNameLiterally++      plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)++      let include_detailed_flags (flag_hash, flags) =+            if gopt Opt_WriteSelfRecompFlags dflags+              then FingerprintWithValue flag_hash (Just flags)+              else FingerprintWithValue flag_hash Nothing++      return (IfaceSelfRecomp+                { mi_sr_flag_hash = include_detailed_flags dyn_flags_info+                , mi_sr_hpc_hash = hpc_hash+                , mi_sr_opt_hash = opt_hash+                , mi_sr_plugin_hash = plugin_hash+                , mi_sr_src_hash = src_hash+                , mi_sr_usages = usages })++-- | Add fingerprints for top-level declarations to a 'ModIface'.+--+-- See Note [Fingerprinting IfaceDecls]+addFingerprints+        :: HscEnv+        -> PartialModIface+        -> IO ModIface+addFingerprints hsc_env iface0 = do+  (abiHashes, caches, decls_w_hashes) <- addAbiHashes hsc_env (mi_mod_info iface0) (mi_public iface0) (mi_deps iface0)++   -- put the declarations in a canonical order, sorted by OccName+  let sorted_decls :: [(Fingerprint, IfaceDecl)]+      sorted_decls = Map.elems $ Map.fromList $+                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]++       -- This key is safe because mi_extra_decls contains tidied things.+      getOcc (IfGblTopBndr b) = getOccName b+      getOcc (IfLclTopBndr fs _ _ details) =+        case details of+          IfRecSelId { ifRecSelFirstCon = first_con }+            -> mkRecFieldOccFS (getOccFS first_con) (ifLclNameFS fs)+          _ -> mkVarOccFS (ifLclNameFS fs)++      binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) ()+      binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs)++      sorted_extra_decls :: Maybe IfaceSimplifiedCore+      sorted_extra_decls = mi_simplified_core iface0 <&> \simpl_core ->+         IfaceSimplifiedCore (sortOn binding_key (mi_sc_extra_decls simpl_core)) (mi_sc_foreign simpl_core)++  -- The interface hash depends on:+  --   - the ABI hash, plus+  --   - the things which can affect whether a module is recompiled+  --   - the module level annotations,+  --   - deps (home and external packages, dependent files)+  let !iface_hash = computeFingerprint putNameLiterally+                        (mi_abi_mod_hash abiHashes,+                         mi_self_recomp_info iface0,+                         mi_deps iface0)++  let final_iface = completePartialModIface iface0 iface_hash+                     sorted_decls sorted_extra_decls abiHashes caches+   --+  return final_iface++++-- The ABI hash should depend on everything in IfacePublic+-- This is however computed in a very convoluted way, so be careful your+-- addition ends up in the right place. In essence all this function does is+-- compute a hash of the arguments.+--+-- Why the convoluted way? Hashing individual declarations allows us to do fine-grained+-- recompilation checking for home package modules, which record precisely what they use+-- from each module.+addAbiHashes :: HscEnv -> IfaceModInfo -> PartialIfacePublic -> Dependencies -> IO (IfaceAbiHashes, IfaceCache, [(Fingerprint, IfaceDecl)])+addAbiHashes hsc_env info+  iface_public+  deps = do+  eps <- hscEPS hsc_env+  let+      -- If you have arrived here by accident then congratulations,+      -- you have discovered the ABI hash. Your reward is to update the ABI hash to+      -- account for your change to the interface file. Omitting your field using a+      -- wildcard may lead to some unfortunate consequences.+      IfacePublic+        exports fixities warns anns decls+        defaults insts fam_insts rules+        trust _trust_pkg -- TODO: trust_pkg ignored+        complete+        _cache+        ()+          = iface_public+      -- And these fields of deps should be in IfacePublic, but in good time.+      Dependencies _ _ _ sig_mods trusted_pkgs boot_mods orph_mods fis_mods  = deps+      decl_warn_fn = mkIfaceDeclWarnCache (fromIfaceWarnings warns)+      export_warn_fn = mkIfaceExportWarnCache (fromIfaceWarnings $ warns)+      fix_fn = mkIfaceFixCache fixities++      this_mod = mi_mod_info_module info+      semantic_mod = mi_mod_info_semantic_module info+      (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    insts+      (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    rules+      (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph fam_insts+      complete_matches = mkIfaceCompleteMap complete+      ann_fn = mkIfaceAnnCache anns++        -- The ABI of a declaration represents everything that is made+        -- visible about the declaration that a client can depend on.+        -- see IfaceDeclABI below.+      declABI :: IfaceDecl -> IfaceDeclABI+       -- TODO: I'm not sure if this should be semantic_mod or this_mod.+       -- See also Note [Identity versus semantic module]+      declABI decl = (this_mod, decl, extras)+        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts+                                  non_orph_fis top_lvl_name_env complete_matches decl++       -- This is used for looking up the Name of a default method+       -- from its OccName. See Note [default method Name]+      top_lvl_name_env =+         mkOccEnv [ (nameOccName nm, nm)+                  | IfaceId { ifName = nm } <- decls ]++       -- Dependency edges between declarations in the current module.+       -- This is computed by finding the free external names of each+       -- declaration, including IfaceDeclExtras (things that a+       -- declaration implicitly depends on).+      edges :: [ Node OccName IfaceDeclABI ]+      edges = [ DigraphNode abi (getOccName decl) out+               | decl <- decls+               , let abi = declABI decl+               , let out = localOccs $ freeNamesDeclABI abi+               ]++      name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n)+      localOccs =+         map (getParent . getOccName)+                        -- NB: names always use semantic module, so+                        -- filtering must be on the semantic module!+                        -- See Note [Identity versus semantic module]+                        . filter ((== semantic_mod) . name_module)+                        . nonDetEltsUniqSet+                   -- It's OK to use nonDetEltsUFM as localOccs is only+                   -- used to construct the edges and+                   -- stronglyConnCompFromEdgedVertices is deterministic+                   -- even with non-deterministic order of edges as+                   -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.+          where getParent :: OccName -> OccName+                getParent occ = lookupOccEnv parent_map occ `orElse` occ++        -- maps OccNames to their parents in the current module.+        -- e.g. a reference to a constructor must be turned into a reference+        -- to the TyCon for the purposes of calculating dependencies.+      parent_map :: OccEnv OccName+      parent_map = foldl' extend emptyOccEnv decls+          where extend env d =+                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]+                  where n = getOccName d++        -- Strongly-connected groups of declarations, in dependency order+      groups :: [SCC IfaceDeclABI]+      groups = stronglyConnCompFromEdgedVerticesOrd edges++      global_hash_fn = mkHashFun hsc_env eps++        -- How to output Names when generating the data to fingerprint.+        -- Here we want to output the fingerprint for each top-level+        -- Name, whether it comes from the current module or another+        -- module.  In this way, the fingerprint for a declaration will+        -- change if the fingerprint for anything it refers to (transitively)+        -- changes.+      mk_put_name :: OccEnv (OccName,Fingerprint)+                   -> WriteBinHandle -> Name -> IO  ()+      mk_put_name local_env bh name+          | isWiredInName name  =  putNameLiterally bh name+           -- wired-in names don't have fingerprints+          | otherwise+          = 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+                     -- and we know a backing impl for it.+                     -- See Note [Identity versus semantic module]+                     | semantic_mod /= this_mod+                     , not (isHoleModule semantic_mod) = global_hash_fn name+                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)+                           `orElse` pprPanic "urk! lookup local fingerprint"+                                       (ppr name $$ ppr local_env)))+                -- This panic indicates that we got the dependency+                -- analysis wrong, because we needed a fingerprint for+                -- an entity that wasn't in the environment.  To debug+                -- it, turn the panic into a trace, uncomment the+                -- pprTraces below, run the compile again, and inspect+                -- the output and the generated .hi file with+                -- --show-iface.+            in hash >>= put_ bh++        -- take a strongly-connected group of declarations and compute+        -- its fingerprint.++      fingerprint_group :: (OccEnv (OccName,Fingerprint),+                             [(Fingerprint,IfaceDecl)])+                         -> SCC IfaceDeclABI+                         -> IO (OccEnv (OccName,Fingerprint),+                                [(Fingerprint,IfaceDecl)])++      fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)+         = do let hash_fn = mk_put_name local_env+                  decl = abiDecl abi+               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do+              let !hash = computeFingerprint hash_fn abi+              env' <- extend_hash_env local_env (hash,decl)+              return (env', (hash,decl) : decls_w_hashes)++      fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)+          = do let stable_abis = sortBy cmp_abiNames abis+                   stable_decls = map abiDecl stable_abis+               local_env1 <- foldM extend_hash_env local_env+                                   (zip (map mkRecFingerprint [0..]) stable_decls)+                -- See Note [Fingerprinting recursive groups]+               let hash_fn = mk_put_name local_env1+               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do+                -- put the cycle in a canonical order+               let !hash = computeFingerprint hash_fn stable_abis+               let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls+                -- See Note [Fingerprinting recursive groups]+               local_env2 <- foldM extend_hash_env local_env pairs+               return (local_env2, pairs ++ decls_w_hashes)++       -- Make a fingerprint from the ordinal position of a binding in its group.+      mkRecFingerprint :: Word64 -> Fingerprint+      mkRecFingerprint i = Fingerprint 0 i++      bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint+      bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ]++       -- we have fingerprinted the whole declaration, but we now need+       -- to assign fingerprints to all the OccNames that it binds, to+       -- use when referencing those OccNames in later declarations.+       --+      extend_hash_env :: OccEnv (OccName,Fingerprint)+                       -> (Fingerprint,IfaceDecl)+                       -> IO (OccEnv (OccName,Fingerprint))+      extend_hash_env env0 (hash,d) =+          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0+                 (ifaceDeclFingerprints hash d))++   --+  (local_env, decls_w_hashes) <-+       foldM fingerprint_group (emptyOccEnv, []) groups++   -- The export hash of a module depends on the orphan hashes of the+   -- orphan modules below us in the dependency tree.  This is the way+   -- that changes in orphans get propagated all the way up the+   -- dependency tree.+   --+   -- NB: do not filter out non-home-package modules!+   -- See Note [Take into account non-home package orphan modules].+  let orph_mods_no_self+       = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]+       $ orph_mods+  dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods_no_self++  let !orphan_hash = computeFingerprint (mk_put_name local_env)+                                     (map ifDFun orph_insts, orph_rules, orph_fis)++  -- Hash of the transitive things in dependencies+  let !dep_hash = computeFingerprint putNameLiterally+                      ( sig_mods, boot_mods+                      , trusted_pkgs -- Trusted packages are like orphans+                      , fis_mods     -- See Note [Orphan-like hash]+                      )++  -- The export list hash doesn't depend on the fingerprints of+  -- the Names it mentions, only the Names themselves, hence putNameLiterally.+  --+  -- As per Note [When to recompile when export lists change?], there are two+  -- separate considerations:+  --+  --  (1) If there is a change in exported orphan instances, we must recompile.+  --+  --      In fact, we must include slightly more items here than only the orphan+  --      instances defined in the current module; see Note [Orphan-like hash].+  --+  --  (2) If there is a change in the exported avails, this may or may not+  --      require recompilation downstream, depending on what is imported.+  --      In the case that the downstream module has a whole module import,+  --      then we recompile when any exports change, by looking at export_hash.+  let+    -- (1) Orphan-like information, see Note [Orphan-like hash].+    !orphan_like_hash =+        computeFingerprint putNameLiterally+          ( orphan_hash, dep_hash, dep_orphan_hashes+          , defaults -- Changes in exported named defaults cause recompilation+          , trust    -- Change of Safe Haskell mode causes recompilation+          )+    -- (2) Exported avails+    !exported_avails_hash = computeFingerprint putNameLiterally exports++  -- the ABI hash depends on:+  --   - decls+  --   - export list+  --   - orphans+  --   - deprecations+  --   - flag abi hash+  let !mod_hash = computeFingerprint putNameLiterally+                      (sort (map fst decls_w_hashes),+                       exported_avails_hash,+                       orphan_like_hash,  -- includes orphan_hash+                       ann_fn AnnModule,+                       warns)++                      -- Surely the ABI depends on "module" annotations?+                      -- Also named defaults++++  let+    final_iface_exts = IfaceAbiHashes+      { mi_abi_mod_hash       = mod_hash+      , mi_abi_orphan         = not (   all ifRuleAuto orph_rules+                                      -- See Note [Orphans and auto-generated rules]+                                 && null orph_insts+                                 && null orph_fis)+      , mi_abi_finsts         = not (null fam_insts)+      , mi_abi_export_avails_hash = exported_avails_hash+      , mi_abi_orphan_like_hash   = orphan_like_hash+      , mi_abi_orphan_hash        = orphan_hash+      }++    caches = IfaceCache+      { mi_cache_decl_warn_fn = decl_warn_fn+      , mi_cache_export_warn_fn = export_warn_fn+      , mi_cache_fix_fn = fix_fn+      , mi_cache_hash_fn = lookupOccEnv local_env+      }+  return (final_iface_exts, caches, decls_w_hashes)+  where++{- Note [Take into account non-home package orphan modules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to take into account all orphan modules, not just those that are from+the home package.++Historically, we filtered out orphan modules which were not from the home+package, justifying it by saying that "we'd pick up the ABI hashes of the+external module instead".  This is wrong.++Suppose that we have:++      module External where+          instance Show (a -> b)++      module Home1 where+          import External++      module Home2 where+          import Home1++The export hash of Home1 needs to reflect the orphan instances of+External. It's true that Home1 will get rebuilt if the orphans+of External, but we also need to make sure Home2 gets rebuilt+as well. See #12733 for more details.++Note [Do not update EPS with your own hi-boot]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When your hs-boot file includes an orphan instance declaration, you may find+that the dep_orphs of a module you import contains reference to yourself.+DO NOT actually load this module or add it to the orphan hashes: you're going+to provide the orphan instances yourself, no need to consult hs-boot; if you do+load the interface into EPS, you will see a duplicate orphan instance.++See also #10182.+-}++-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules+-- (in particular, the orphan modules which are transitively imported by the+-- current module).+--+-- Q: Why do we need the hash at all, doesn't the list of transitively+-- imported orphan modules suffice?+--+-- A: If one of our transitive imports adds a new orphan instance, our+-- export hash must change so that modules which import us rebuild.  If we just+-- hashed the [Module], the hash would not change even when a new instance was+-- added to a module that already had an orphan instance.+--+-- Q: Why don't we just hash the orphan hashes of our direct dependencies?+-- Why the full transitive closure?+--+-- A: Suppose we have these modules:+--+--      module A where+--          instance Show (a -> b) where+--      module B where+--          import A -- **+--      module C where+--          import A+--          import B+--+-- Whether or not we add or remove the import to A in B affects the+-- orphan hash of B.  But it shouldn't really affect the orphan hash+-- of C.  If we hashed only direct dependencies, there would be no+-- way to tell that the net effect was a wash, and we'd be forced+-- to recompile C and everything else.+getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]+getOrphanHashes hsc_env mods = do+  let+    dflags     = hsc_dflags hsc_env+    ctx        = initSDocContext dflags defaultUserStyle+    get_orph_hash mod = do+          iface <- initIfaceLoad hsc_env . withIfaceErr ctx+                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem+          return (mi_orphan_hash iface)++  mapM get_orph_hash mods+++{-+************************************************************************+*                                                                      *+          The ABI of an IfaceDecl+*                                                                      *+************************************************************************++Note [The ABI of an IfaceDecl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ABI of a declaration consists of:++   (a) the full name of the identifier (inc. module and package,+       because these are used to construct the symbol name by which+       the identifier is known externally).++   (b) the declaration itself, as exposed to clients.  That is, the+       definition of an Id is included in the fingerprint only if+       it is made available as an unfolding in the interface.++   (c) the fixity of the identifier (if it exists)+   (d) for Ids: rules+   (e) for classes: instances, fixity & rules for methods+   (f) for datatypes: instances, fixity & rules for constrs++Items (c)-(f) are not stored in the IfaceDecl, but instead appear+elsewhere in the interface file.  But they are *fingerprinted* with+the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,+and fingerprinting that as part of the declaration.+-}++type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)++data IfaceDeclExtras+  = IfaceIdExtras IfaceIdExtras++  | IfaceDataExtras+       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)+       [IfaceInstABI]           -- Local class and family instances of this tycon+                                -- See Note [Orphans] in GHC.Core.InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations++  | IfaceClassExtras+       (Maybe Fixity)           -- Fixity of the class itself (if it exists)+       [IfaceInstABI]           -- Local instances of this class *or*+                                --   of its associated data types+                                -- See Note [Orphans] in GHC.Core.InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations+       [IfExtName]              -- Default methods. If a module+                                -- mentions a class, then it can+                                -- instantiate the class and thereby+                                -- use the default methods, so we must+                                -- include these in the fingerprint of+                                -- a class.++  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]++  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]++  | IfacePatSynExtras (Maybe Fixity) [IfaceCompleteMatchABI] -- ^ COMPLETE pragmas that this PatSyn appears in++  | IfaceOtherDeclExtras++data IfaceIdExtras+  = IdExtras+       (Maybe Fixity)           -- Fixity of the Id (if it exists)+       [IfaceRule]              -- Rules for the Id+       [AnnPayload]             -- Annotations for the Id+       [IfaceCompleteMatchABI]  -- See Note [Fingerprinting complete matches] for why this is in IdExtras++-- When hashing a class or family instance, we hash only the+-- DFunId or CoAxiom, because that depends on all the+-- information about the instance.+--+type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance++-- See Note [Fingerprinting complete matches]+type IfaceCompleteMatchABI = (Fingerprint, Maybe IfExtName)++abiDecl :: IfaceDeclABI -> IfaceDecl+abiDecl (_, decl, _) = decl++cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering+cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`+                         getOccName (abiDecl abi2)++freeNamesDeclABI :: IfaceDeclABI -> NameSet+freeNamesDeclABI (_mod, decl, extras) =+  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras++freeNamesDeclExtras :: IfaceDeclExtras -> NameSet+freeNamesDeclExtras (IfaceIdExtras id_extras)+  = freeNamesIdExtras id_extras+freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)+  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)+freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)+  = unionNameSets $+      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs+freeNamesDeclExtras (IfaceSynonymExtras _ _)+  = emptyNameSet+freeNamesDeclExtras (IfaceFamilyExtras _ insts _)+  = mkNameSet insts+freeNamesDeclExtras (IfacePatSynExtras _ complete)+  = unionNameSets (map freeNamesIfaceCompleteABI complete)+freeNamesDeclExtras IfaceOtherDeclExtras+  = emptyNameSet++freeNamesIdExtras :: IfaceIdExtras -> NameSet+freeNamesIdExtras (IdExtras _ rules _ complete) =+  unionNameSets (map freeNamesIfRule rules ++ map freeNamesIfaceCompleteABI complete)++-- | Extract free names from a COMPLETE pragma ABI+freeNamesIfaceCompleteABI :: IfaceCompleteMatchABI -> NameSet+freeNamesIfaceCompleteABI (_, mb_ty) = case mb_ty of+  Nothing -> emptyNameSet+  Just ty -> unitNameSet ty+++instance Outputable IfaceDeclExtras where+  ppr IfaceOtherDeclExtras       = Outputable.empty+  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras+  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]+  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]+  ppr (IfaceDataExtras fix insts anns stuff)+                    = vcat [ppr fix, ppr_insts insts, ppr anns,+                            ppr_id_extras_s stuff]+  ppr (IfaceClassExtras fix insts anns stuff defms) =+    vcat [ppr fix, ppr_insts insts, ppr anns,+          ppr_id_extras_s stuff, ppr defms]+  ppr (IfacePatSynExtras fix complete) = vcat [ppr fix, ppr complete]++ppr_insts :: [IfaceInstABI] -> SDoc+ppr_insts _ = text "<insts>"++ppr_id_extras_s :: [IfaceIdExtras] -> SDoc+ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)++ppr_id_extras :: IfaceIdExtras -> SDoc+ppr_id_extras (IdExtras fix rules anns complete) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns) $$ vcat (map ppr complete)++-- This instance is used only to compute fingerprints+instance Binary IfaceDeclExtras where+  get _bh = panic "no get for IfaceDeclExtras"+  put_ bh (IfaceIdExtras extras) = do+   putByte bh 1; put_ bh extras+  put_ bh (IfaceDataExtras fix insts anns cons) = do+   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons+  put_ bh (IfaceClassExtras fix insts anns methods defms) = do+   putByte bh 3+   put_ bh fix+   put_ bh insts+   put_ bh anns+   put_ bh methods+   put_ bh defms+  put_ bh (IfaceSynonymExtras fix anns) = do+   putByte bh 4; put_ bh fix; put_ bh anns+  put_ bh (IfaceFamilyExtras fix finsts anns) = do+   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns+  put_ bh (IfacePatSynExtras fix complete) = do+   putByte bh 6; put_ bh fix; put_ bh complete+  put_ bh IfaceOtherDeclExtras = putByte bh 7++instance Binary IfaceIdExtras where+  get _bh = panic "no get for IfaceIdExtras"+  put_ bh (IdExtras fix rules anns complete) = do { put_ bh fix; put_ bh rules; put_ bh anns; put_ bh complete }++declExtras :: (OccName -> Maybe Fixity)+           -> (AnnCacheKey -> [AnnPayload])+           -> OccEnv [IfaceRule]+           -> OccEnv [IfaceClsInst]+           -> OccEnv [IfaceFamInst]+           -> OccEnv IfExtName          -- lookup default method names+           -> OccEnv [IfaceCompleteMatchABI]          -- lookup complete matches+           -> IfaceDecl+           -> IfaceDeclExtras++declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env complete_env decl+  = case decl of+      IfaceId{} -> IfaceIdExtras (id_extras n)+      IfaceData{ifCons=cons} ->+                     IfaceDataExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) +++                         map ifDFun         (lookupOccEnvL inst_env n))+                        (ann_fn (AnnOccName n))+                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))+      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->+                     IfaceClassExtras (fix_fn n) insts (ann_fn (AnnOccName n)) meths defms+          where+            insts = (map ifDFun $ (concatMap at_extras ats)+                                    ++ lookupOccEnvL inst_env n)+                           -- Include instances of the associated types+                           -- as well as instances of the class (#5147)+            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]+            -- Names of all the default methods (see Note [default method Name])+            defms = [ dmName+                    | IfaceClassOp bndr _ (Just _) <- sigs+                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)+                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]+      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)+                                           (ann_fn (AnnOccName n))+      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))+                        (ann_fn (AnnOccName n))+      IfacePatSyn{} -> IfacePatSynExtras (fix_fn n) (lookup_complete_match n)+      _other -> IfaceOtherDeclExtras+  where+        n = getOccName decl+        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn (AnnOccName occ)) (lookup_complete_match occ)+        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)++        lookup_complete_match occ = lookupOccEnvL complete_env occ++{- Note [default method Name] (see also #15970)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Names for the default methods aren't available in Iface syntax.++* We originally start with a DefMethInfo from the class, contain a+  Name for the default method++* We turn that into Iface syntax as a DefMethSpec which lacks a Name+  entirely. Why? Because the Name can be derived from the method name+  (in GHC.IfaceToCore), so doesn't need to be serialised into the interface+  file.++But now we have to get the Name back, because the class declaration's+fingerprint needs to depend on it (this was the bug in #15970).  This+is done in a slightly convoluted way:++* Then, in addFingerprints we build a map that maps OccNames to Names++* We pass that map to declExtras which laboriously looks up in the map+  (using the derived occurrence name) to recover the Name we have just+  thrown away.+-}++lookupOccEnvL :: OccEnv [v] -> OccName -> [v]+lookupOccEnvL env k = lookupOccEnv env k `orElse` []++{-+-- for testing: use the md5sum command to generate fingerprints and+-- compare the results against our built-in version.+  fp' <- oldMD5 dflags bh+  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')+               else return fp++oldMD5 dflags bh = do+  tmp <- newTempName dflags CurrentModule "bin"+  writeBinMem bh tmp+  tmp2 <- newTempName dflags CurrentModule "md5"+  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2+  r <- system cmd+  case r of+    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)+    ExitSuccess -> do+        hash_str <- readFile tmp2+        return $! readHexFingerprint hash_str+-}++----------------------+-- mkOrphMap partitions instance decls or rules into+--      (a) an OccEnv for ones that are not orphans,+--          mapping the local OccName to a list of its decls+--      (b) a list of orphan decls+mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl+          -> [decl]             -- Sorted into canonical order+          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;+                                --      each sublist in canonical order+              [decl])           -- Orphan decls; in canonical order+mkOrphMap get_key decls+  = foldl' go (emptyOccEnv, []) decls+  where+    go (non_orphs, orphs) d+        | NotOrphan occ <- get_key d+        = (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs)+        | otherwise = (non_orphs, d:orphs)++-- -----------------------------------------------------------------------------+-- Look up parents and versions of Names++-- This is like a global version of the mi_hash_fn field in each ModIface.+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get+-- the parent and version info.++mkHashFun+        :: HscEnv                       -- needed to look up versions+        -> ExternalPackageState         -- ditto+        -> (Name -> IO Fingerprint)+mkHashFun hsc_env eps name+  | isHoleModule orig_mod+  = lookup (mkHomeModule home_unit (moduleName orig_mod))+  | otherwise+  = lookup orig_mod+  where+      home_unit = hsc_home_unit hsc_env+      dflags = hsc_dflags hsc_env+      hpt = hsc_HUG hsc_env+      pit = eps_PIT eps+      ctx = initSDocContext dflags defaultUserStyle+      occ = nameOccName name+      orig_mod = nameModule name+      lookup mod = do+        massertPpr (isExternalName name) (ppr name)+        iface <- lookupIfaceByModule hpt pit mod >>= \case+                  Just iface -> return iface+                  Nothing ->+                      -- This can occur when we're writing out ifaces for+                      -- requirements; we didn't do any /real/ typechecking+                      -- so there's no guarantee everything is loaded.+                      -- Kind of a heinous hack.+                      initIfaceLoad hsc_env . withIfaceErr ctx+                          $ withoutDynamicNow+                            -- If you try and load interfaces when dynamic-too+                            -- enabled then it attempts to load the dyn_hi and hi+                            -- interface files. Backpack doesn't really care about+                            -- dynamic object files as it isn't doing any code+                            -- generation so -dynamic-too is turned off.+                            -- Some tests fail without doing this (such as T16219),+                            -- but they fail because dyn_hi files are not found for+                            -- one of the dependencies (because they are deliberately turned off)+                            -- Why is this check turned off here? That is unclear but+                            -- just one of the many horrible hacks in the backpack+                            -- implementation.+                          $ loadInterface (text "lookupVers2") mod ImportBySystem+        return $ snd (mi_hash_fn iface occ `orElse`+                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))++{- Note [Fingerprinting complete matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The presence or absence of COMPLETE pragmas influences the programs we generate,+and not just error messages, because pattern fallibility information feeds into+the desugaring of do notation (e.g. whether to use 'fail' from 'MonadFail').++As far as recompilation checking is concerned, there are two questions we need+to answer:++  Usage: When is a COMPLETE pragma used?+  Fingerprinting: What is the Fingerprint of a COMPLETE pragma, i.e. when+                  do we consider a COMPLETE pragma to have changed?++Usage++  There isn't a straightforward way to compute which COMPLETE pragmas are+  "used" during pattern-match checking. So we have to come up with a conservative+  approximation.++  The most conservative option is to consider a COMPLETE pragma to always be+  used, much like we treat orphan class instances today. This means that any+  change at all would require recompilation.++  A slightly finer grained option, which is what is currently implemented, is to+  consider a COMPLETE pragma to be used only when the importing module actually+  mentions at least one of the constructors in the COMPLETE pragma.++  Tested in: RecompCompletePragma++Fingerprinting++  Most conservatively, the fingerprint of a COMPLETE pragma would be the hash of+  all the constructors it mentions (together with the hash of the result TyCon,+  if any).++  However, for the purposes of the pattern-match checker, we only really care+  about the Names of the constructors in a COMPLETE pragma; it doesn't matter+  what the definitions of the constructors are. The above criterion would+  pessimistically lead to recompilation in the following scenario:++    module M where+      pattern MyJust :: a -> Maybe a+      pattern MyJust a = Just a+      pattern MyNothing :: Maybe a+      pattern MyNothing = Nothing+      {-# COMPLETE MyJust, MyNothing #-}++    module N where+      import M+      f :: Maybe Int -> Int+      f (MyJust x) = x; f _ = 0++  In this example, if we change the definition of the 'MyNothing' pattern, then+  we will recompile 'M', because 'N' uses the 'MyJust' constructor, 'MyJust'+  appears in the imported {-# COMPLETE MyJust, MyNothing #-} pragma, and+  'MyNothing' has changed.++  However, this is needless: the RHS of the pattern synonym declaration for+  'MyNothing' is completely irrelevant to 'N'. So, to avoid this extraneous+  recompilation, we implement the following finer-grained criterion: the+  Fingerprint of a COMPLETE pragma is the hash of the 'Name's of the mentioned+  constructors (hashed together with the Fingerprint of the result TyCon, if any).++  Tested in: RecompCompleteIndependence.+-}++-- | Make a map from OccNames of pattern synonyms or data constructors to a list+-- of COMPLETE pragmas relevant for that OccName.+-- See Note [Fingerprinting complete matches]+mkIfaceCompleteMap :: [IfaceCompleteMatch] -> OccEnv [IfaceCompleteMatchABI]+mkIfaceCompleteMap complete =+  mkOccEnv_C (++) $+    concatMap (\m@(IfaceCompleteMatch syns _) ->+                  let complete_abi = mkIfaceCompleteMatchABI m+                  in [(getOccName syn, [complete_abi]) | syn <- syns]+    ) complete+  where+    mkIfaceCompleteMatchABI (IfaceCompleteMatch syns ty) =+      (computeFingerprint putNameLiterally syns, ty)++data AnnCacheKey = AnnModule | AnnOccName OccName++-- | Creates cached lookup for the 'mi_anns' field of ModIface+mkIfaceAnnCache :: [IfaceAnnotation] -> AnnCacheKey -> [AnnPayload]+mkIfaceAnnCache anns+  = \n -> case n of+            AnnModule -> module_anns+            AnnOccName occn -> lookupOccEnv env occn `orElse` []+  where+    (module_anns, occ_anns) = partitionEithers $ map classify anns+    classify (IfaceAnnotation target value) =+      case target of+          NamedTarget occn -> Right (occn, [value])+          ModuleTarget _   -> Left value++    -- flipping (++), so the first argument is always short+    env = mkOccEnv_C (flip (++)) occ_anns
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -19,11 +19,14 @@ import GHC.Types.SafeHaskell import GHC.Utils.Fingerprint import GHC.Iface.Recomp.Binary-import GHC.Core.Opt.CallerCC () -- for Binary instances+import GHC.Iface.Flags  import GHC.Data.EnumSet as EnumSet import System.FilePath (normalise)+import Data.Maybe +-- The subset of DynFlags which is used by the recompilation checker.+ -- | Produce a fingerprint of a @DynFlags@ value. We only base -- the finger print on important fields in @DynFlags@ so that -- the recompilation checker can use this fingerprint.@@ -32,7 +35,7 @@ -- file, not the actual 'Module' according to our 'DynFlags'. fingerprintDynFlags :: HscEnv -> Module                     -> (WriteBinHandle -> Name -> IO ())-                    -> IO Fingerprint+                    -> (Fingerprint, IfaceDynFlags)  fingerprintDynFlags hsc_env this_mod nameio =     let dflags@DynFlags{..} = hsc_dflags hsc_env@@ -43,53 +46,59 @@         -- oflags   = sort $ filter filterOFlags $ flags dflags          -- all the extension flags and the language-        lang = (fmap fromEnum language,-                map fromEnum $ EnumSet.toList extensionFlags)+        lang = fmap IfaceLanguage language+        exts = map IfaceExtension $ 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 Haskell C/CPP Preprocessor-        cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit-            -- normalise: eliminate spurious differences due to "./foo" vs "foo"-              , picPOpts dflags-              , opt_P_signature dflags)+        cpp = IfaceCppOptions+                { ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit+                -- normalise: eliminate spurious differences due to "./foo" vs "foo"+                , ifaceCppOpts = picPOpts dflags+                , ifaceCppSig =  opt_P_signature dflags+                }             -- See Note [Repeated -optP hashing] +         -- -I, -D and -U flags affect JavaScript C/CPP Preprocessor-        js = ( map normalise $ flattenIncludes includePathsMinusImplicit+        js = IfaceCppOptions+              { ifaceCppIncludes =  map normalise $ flattenIncludes includePathsMinusImplicit             -- normalise: eliminate spurious differences due to "./foo" vs "foo"-              , picPOpts dflags-              , opt_JSP_signature dflags)+              , ifaceCppOpts = picPOpts dflags+              , ifaceCppSig = opt_JSP_signature dflags+              }             -- See Note [Repeated -optP hashing]          -- -I, -D and -U flags affect C-- CPP Preprocessor-        cmm = ( map normalise $ flattenIncludes includePathsMinusImplicit+        cmm = IfaceCppOptions {+              ifaceCppIncludes =  map normalise $ flattenIncludes includePathsMinusImplicit             -- normalise: eliminate spurious differences due to "./foo" vs "foo"-              , picPOpts dflags-              , opt_CmmP_signature dflags)+              , ifaceCppOpts = picPOpts dflags+              , ifaceCppSig = ([], opt_CmmP_signature dflags)+              }          -- Note [path flags and recompilation]         paths = [ hcSuf ]          -- -fprof-auto etc.-        prof = if sccProfilingEnabled dflags then fromEnum profAuto else 0+        prof = if sccProfilingEnabled dflags then Just (IfaceProfAuto profAuto) else Nothing          -- Ticky         ticky =-          map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag]+          mapMaybe (\f -> (if f `gopt` dflags then Just (IfaceGeneralFlag f) else Nothing)) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag]          -- Other flags which affect code generation-        codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags)+        codegen = mapMaybe (\f -> (if f `gopt` dflags then Just (IfaceGeneralFlag f) else Nothing)) (EnumSet.toList codeGenFlags)          -- Did we include core for all bindings?         fat_iface = gopt Opt_WriteIfSimplifiedCore dflags -        flags = ((mainis, safeHs, lang, cpp, js, cmm), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface))+        f = IfaceDynFlags mainis safeHs lang exts cpp js cmm paths prof ticky codegen fat_iface debugLevel callerCcFilters -    in -- pprTrace "flags" (ppr flags) $-       computeFingerprint nameio flags+    in (computeFingerprint nameio f, f)  -- Fingerprint the optimisation info. We keep this separate from the rest of -- the flags because GHCi users (especially) may wish to ignore changes in@@ -98,7 +107,7 @@ -- See Note [Ignoring some flag changes] fingerprintOptFlags :: DynFlags                       -> (WriteBinHandle -> Name -> IO ())-                      -> IO Fingerprint+                      -> Fingerprint fingerprintOptFlags DynFlags{..} nameio =       let         -- See https://gitlab.haskell.org/ghc/ghc/issues/10923@@ -116,7 +125,7 @@ -- See Note [Ignoring some flag changes] fingerprintHpcFlags :: DynFlags                       -> (WriteBinHandle -> Name -> IO ())-                      -> IO Fingerprint+                      -> Fingerprint fingerprintHpcFlags dflags@DynFlags{..} nameio =       let         -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798
compiler/GHC/Iface/Tidy.hs view
@@ -1,7 +1,5 @@  {-# LANGUAGE DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE NamedFieldPuns #-}  {-@@ -51,16 +49,14 @@  import GHC.Core import GHC.Core.Unfold--- import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy import GHC.Core.Seq         ( seqBinds ) import GHC.Core.Opt.Arity   ( exprArity, typeArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv import GHC.Core.Type-import GHC.Core.DataCon import GHC.Core.TyCon-import GHC.Core.Class+import GHC.Core.TyCo.Tidy import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )  import GHC.Iface.Tidy.StaticPtrTable@@ -77,10 +73,10 @@ import GHC.Types.Var.Set import GHC.Types.Var import GHC.Types.Id-import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info import GHC.Types.Demand  ( isDeadEndAppSig, isNopSig, nopSig, isDeadEndSig ) import GHC.Types.Basic+import GHC.Types.TyThing( implicitTyConThings ) import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Types.Name.Cache@@ -411,11 +407,8 @@                           , mg_boot_exports     = boot_exports                           }) = do -  let implicit_binds = concatMap getImplicitBinds tcs-      all_binds = implicit_binds ++ binds--  (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod all_binds imp_rules-  let (trimmed_binds, trimmed_rules) = findExternalRules opts all_binds imp_rules unfold_env+  (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod tcs binds imp_rules+  let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env    (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds @@ -478,7 +471,10 @@                  , cg_ccs           = S.toList local_ccs                  , cg_foreign       = all_foreign_stubs                  , cg_foreign_files = foreign_files-                 , cg_dep_pkgs      = dep_direct_pkgs deps+                 -- TODO: Check whether we need to account for levels here.+                 -- It seems that this field just gets used to write a comment+                 -- in C codegen, so it's value doesn't affect an important result.+                 , cg_dep_pkgs      = S.map snd (dep_direct_pkgs deps)                  , cg_modBreaks     = modBreaks                  , cg_spt_entries   = spt_entries                  }@@ -528,7 +524,6 @@      do_binder cs b = maybe cs (go cs) (get_unf b) -     -- Unfoldings may have cost centres that in the original definion are     -- optimized away, see #5889.     get_unf = maybeUnfoldingTemplate . realIdUnfolding@@ -590,80 +585,8 @@     modest cost in interface file growth, which is limited to the     bits reqd to describe those data constructors. -************************************************************************-*                                                                      *-        Implicit bindings-*                                                                      *-************************************************************************--Note [Injecting implicit bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We inject the implicit bindings right at the end, in GHC.Core.Tidy.-Some of these bindings, notably record selectors, are not-constructed in an optimised form.  E.g. record selector for-        data T = MkT { x :: {-# UNPACK #-} !Int }-Then the unfolding looks like-        x = \t. case t of MkT x1 -> let x = I# x1 in x-This generates bad code unless it's first simplified a bit.  That is-why GHC.Core.Unfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of-optimisation first.  (Only matters when the selector is used curried;-eg map x ys.)  See #2070.--[Oct 09: in fact, record selectors are no longer implicit Ids at all,-because we really do want to optimise them properly. They are treated-much like any other Id.  But doing "light" optimisation on an implicit-Id still makes sense.]--At one time I tried injecting the implicit bindings *early*, at the-beginning of SimplCore.  But that gave rise to real difficulty,-because GlobalIds are supposed to have *fixed* IdInfo, but the-simplifier and other core-to-core passes mess with IdInfo all the-time.  The straw that broke the camels back was when a class selector-got the wrong arity -- ie the simplifier gave it arity 2, whereas-importing modules were expecting it to have arity 1 (#2844).-It's much safer just to inject them right at the end, after tidying.--Oh: two other reasons for injecting them late:--  - If implicit Ids are already in the bindings when we start tidying,-    we'd have to be careful not to treat them as external Ids (in-    the sense of chooseExternalIds); else the Ids mentioned in *their*-    RHSs will be treated as external and you get an interface file-    saying      a18 = <blah>-    but nothing referring to a18 (because the implicit Id is the-    one that does, and implicit Ids don't appear in interface files).--  - More seriously, the tidied type-envt will include the implicit-    Id replete with a18 in its unfolding; but we won't take account-    of a18 when computing a fingerprint for the class; result chaos.--There is one sort of implicit binding that is injected still later,-namely those for data constructor workers. Reason (I think): it's-really just a code generation trick.... binding itself makes no sense.-See Note [Data constructor workers] in "GHC.CoreToStg.Prep". -} -getImplicitBinds :: TyCon -> [CoreBind]-getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc-  where-    cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)--getTyConImplicitBinds :: TyCon -> [CoreBind]-getTyConImplicitBinds tc-  | isDataTyCon tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))-  | otherwise      = []-    -- The 'otherwise' includes family TyCons of course, but also (less obviously)-    --  * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make-    --  * type data: we don't want any code for type-only stuff (#24620)--getClassImplicitBinds :: Class -> [CoreBind]-getClassImplicitBinds cls-  = [ NonRec op (mkDictSelRhs cls val_index)-    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]--get_defn :: Id -> CoreBind-get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))- {- ************************************************************************ *                                                                      *@@ -683,12 +606,13 @@  chooseExternalIds :: TidyOpts                   -> Module+                  -> [TyCon]                   -> [CoreBind]                   -> [CoreRule]                   -> IO (UnfoldEnv, TidyOccEnv)                   -- Step 1 from the notes above -chooseExternalIds opts mod binds imp_id_rules+chooseExternalIds opts mod tcs binds imp_id_rules   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders        ; tidy_internal internal_ids unfold_env1 occ_env1 }@@ -719,17 +643,16 @@   binders          = map fst $ flattenBinds binds   binder_set       = mkVarSet binders -  avoids   = [getOccName name | bndr <- binders,-                                let name = idName bndr,-                                isExternalName name ]+  avoids   = [ getOccName name | bndr <- binders,+                                 let name = idName bndr,+                                 isExternalName name ]+          ++ [ getOccName thing | tc <- tcs+                                , thing <- implicitTyConThings tc ]                 -- In computing our "avoids" list, we must include                 --      all implicit Ids                 --      all things with global names (assigned once and for                 --                                      all by the renamer)                 -- since their names are "taken".-                -- The type environment is a convenient source of such things.-                -- In particular, the set of binders doesn't include-                -- implicit Ids at this stage.          -- We also make sure to avoid any exported binders.  Consider         --      f{-u1-} = 1     -- Local decl@@ -950,7 +873,7 @@ dffvExpr (Var v)              = insert v dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2 dffvExpr (Lam v e)            = extendScope v (dffvExpr e)-dffvExpr (Tick (Breakpoint _ _ ids _) e) = mapM_ insert ids >> dffvExpr e+dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e dffvExpr (Tick _other e)    = dffvExpr e dffvExpr (Cast e _)           = dffvExpr e dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)@@ -1310,7 +1233,9 @@     (bndr1, rhs1)    where-    Just (name',show_unfold) = lookupVarEnv unfold_env bndr+    (name',show_unfold) = case lookupVarEnv unfold_env bndr of+                            Just stuff -> stuff+                            Nothing    -> pprPanic "tidyTopPair" (ppr bndr)     !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs     bndr1    = mkGlobalId details name' ty' idinfo'     details  = idDetails cbv_bndr -- Preserve the IdDetails@@ -1362,7 +1287,7 @@      sig = dmdSigInfo idinfo     final_sig | not (isNopSig sig)-              = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig+              = warnPprTrace (bottom_hidden sig) "tidyTopIdInfo" (ppr name <+> ppr sig) sig                -- No demand signature, so try a               -- cheap-and-cheerful bottom analyser@@ -1378,7 +1303,7 @@               | otherwise               = cpr -    _bottom_hidden id_sig+    bottom_hidden id_sig       = case mb_bot_str of           Nothing            -> False           Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity)
compiler/GHC/IfaceToCore.hs view
@@ -13,6 +13,7 @@ {-# LANGUAGE RecursiveDo #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} @@ -33,6 +34,7 @@         hydrateCgBreakInfo  ) where + import GHC.Prelude  import GHC.ByteCode.Types@@ -44,7 +46,6 @@ import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) import GHC.Builtin.Types -import GHC.Iface.Decl (toIfaceBooleanFormula) import GHC.Iface.Syntax import GHC.Iface.Load import GHC.Iface.Env@@ -74,18 +75,19 @@ import GHC.Core.Lint import GHC.Core.Make import GHC.Core.Class+import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Ppr -import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModIface import GHC.Unit.Home.ModInfo+import qualified GHC.Unit.Home.Graph as HUG  import GHC.Utils.Outputable import GHC.Utils.Misc@@ -104,6 +106,7 @@ import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Types.CompleteMatch import GHC.Types.SrcLoc+import GHC.Types.Avail import GHC.Types.TypeEnv import GHC.Types.Unique.FM import GHC.Types.Unique.DSet ( mkUniqDSet )@@ -114,9 +117,9 @@ import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Name-import GHC.Types.Name.Reader+import GHC.Types.Name.Set import GHC.Types.Name.Env-import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv )+import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv, DefaultProvenance(..) ) import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Id.Info@@ -124,17 +127,23 @@ import GHC.Types.TyThing import GHC.Types.Error +import GHC.Parser.Annotation (noLocA)++import GHC.Hs.Extension ( GhcRn )+ import GHC.Fingerprint-import qualified GHC.Data.BooleanFormula as BF  import Control.Monad-import GHC.Parser.Annotation import GHC.Driver.Env.KnotVars import GHC.Unit.Module.WholeCoreBindings import Data.IORef import Data.Foldable+import Data.List(nub) import GHC.Builtin.Names (ioTyConName, rOOT_MAIN) import GHC.Iface.Errors.Types++import Language.Haskell.Syntax.BooleanFormula (BooleanFormula)+import Language.Haskell.Syntax.BooleanFormula qualified as BF(BooleanFormula(..)) import Language.Haskell.Syntax.Extension (NoExtField (NoExtField))  {-@@ -295,14 +304,38 @@                   plusNameEnv_C mergeIfaceClassOp                     (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])                     (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])+       in d1 { ifBody = (ifBody d1) {                 ifSigs  = ops,-                ifMinDef = toIfaceBooleanFormula . BF.mkOr . map (noLocA . fromIfaceBooleanFormula) $ [bf1, bf2]+                ifMinDef = mkOr [ bf1, bf2]                 }             } `withRolesFrom` d2     -- It doesn't matter; we'll check for consistency later when     -- we merge, see 'mergeSignatures'     | otherwise              = d1 `withRolesFrom` d2+      where+        -- The reason we need to duplicate mkOr here, instead of+        -- using BooleanFormula's mkOr and just doing the loop like:+        -- `toIfaceBooleanFormula . mkOr . fromIfaceBooleanFormula`+        -- is quite subtle. Say we have the following minimal pragma:+        -- {-# MINIMAL f | g #-}. If we use fromIfaceBooleanFormula+        -- first, we will end up doing+        -- `nub [Var (mkUnboundName f), Var (mkUnboundName g)]`,+        -- which might seem fine, but Name equallity is decided by+        -- their Unique, which will be identical since mkUnboundName+        -- just stuffs the mkUnboundKey unqiue into both.+        -- So the result will be {-# MINIMAL f #-}, oopsie.+        -- Duplication it is.+        mkOr :: [IfaceBooleanFormula] -> IfaceBooleanFormula+        mkOr = maybe (IfAnd []) (mkOr' . nub . concat) . mapM fromOr+          where+          -- See Note [Simplification of BooleanFormulas]+          fromOr bf = case bf of+            (IfOr xs)  -> Just xs+            (IfAnd []) -> Nothing+            _        -> Just [bf]+          mkOr' [x] = x+          mkOr' xs = IfOr xs  -- Note [Role merging] -- ~~~~~~~~~~~~~~~~~~~@@ -351,7 +384,7 @@     = d1 { ifRoles = mergeRoles roles1 roles2 }     | otherwise = d1   where-    mergeRoles roles1 roles2 = zipWithEqual "mergeRoles" max roles1 roles2+    mergeRoles roles1 roles2 = zipWithEqual max roles1 roles2  isRepInjectiveIfaceDecl :: IfaceDecl -> Bool isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon{} } = True@@ -577,10 +610,11 @@                 -- And that's fine, because if M's ModInfo is in the HPT, then                 -- it's been compiled once, and we don't need to check the boot iface           then do { (_, hug) <- getEpsAndHug-                 ; case lookupHugByModule mod hug  of+                  ; liftIO $+                    HUG.lookupHugByModule mod hug >>= pure . \case                       Just info | mi_boot (hm_iface info) == IsBoot-                                -> return $ SelfBoot { sb_mds = hm_details info }-                      _ -> return NoSelfBoot }+                                -> SelfBoot { sb_mds = hm_details info }+                      _ -> NoSelfBoot }           else do          -- OK, so we're in one-shot mode.@@ -773,7 +807,7 @@                          ifBody = IfAbstractClass})   = bindIfaceTyConBinders binders $ \ binders' -> do     { fds  <- mapM tc_fd rdr_fds-    ; cls  <- buildClass tc_name binders' roles fds Nothing+    ; cls  <- buildAbstractClass tc_name binders' roles fds     ; return (ATyCon (classTyCon cls)) }  tc_iface_decl _parent ignore_prags@@ -784,7 +818,7 @@                          ifBody = IfConcreteClass {                              ifClassCtxt = rdr_ctxt,                              ifATs = rdr_ats, ifSigs = rdr_sigs,-                             ifMinDef = if_mindef+                             ifMinDef = if_mindef, ifUnary = unary                          }})   = bindIfaceTyConBinders binders $ \ binders' -> do     { traceIf (text "tc-iface-class1" <+> ppr tc_name)@@ -793,12 +827,11 @@     ; sigs <- mapM tc_sig rdr_sigs     ; fds  <- mapM tc_fd rdr_fds     ; traceIf (text "tc-iface-class3" <+> ppr tc_name)-    ; let mindef_occ = fromIfaceBooleanFormula if_mindef-    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS . ifLclNameFS) mindef_occ+    ; mindef <- tc_boolean_formula if_mindef     ; cls  <- fixM $ \ cls -> do               { ats  <- mapM (tc_at cls) rdr_ats               ; traceIf (text "tc-iface-class4" <+> ppr tc_name)-              ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }+              ; buildClass tc_name binders' roles fds ctxt ats sigs mindef unary }     ; return (ATyCon (classTyCon cls)) }   where    tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)@@ -843,6 +876,12 @@                   -- e.g.   type AT a; type AT b = AT [b]   #8002           return (ATI tc mb_def) +   tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn)+   tc_boolean_formula (IfAnd ibfs  ) = BF.And    . map noLocA <$> traverse tc_boolean_formula ibfs+   tc_boolean_formula (IfOr ibfs   ) = BF.Or     . map noLocA <$> traverse tc_boolean_formula ibfs+   tc_boolean_formula (IfParens ibf) = BF.Parens .     noLocA <$>          tc_boolean_formula ibf+   tc_boolean_formula (IfVar nm    ) = BF.Var    .     noLocA <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm)+    mk_sc_doc pred = text "Superclass" <+> ppr pred    mk_at_doc tc = text "Associated type" <+> ppr tc    mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]@@ -1198,7 +1237,7 @@                                       ; return (HsUnpack (Just co)) }      src_strict :: IfaceSrcBang -> HsSrcBang-    src_strict (IfSrcBang unpk bang) = mkHsSrcBang NoSourceText unpk bang+    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang  tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] tcIfaceEqSpec spec@@ -1295,7 +1334,7 @@        ; let warn = fmap fromIfaceWarningTxt iface_warn        ; return ClassDefaults { cd_class = cls                               , cd_types = tys'-                              , cd_module = Just this_mod+                              , cd_provenance = DP_Imported this_mod                               , cd_warn = warn } }     where        tyThingConClass :: TyThing -> Class@@ -1694,9 +1733,9 @@ tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push) tcIfaceTickish (IfaceSource src name)   = return (SourceNote src (LexicalFastString name))-tcIfaceTickish (IfaceBreakpoint ix fvs modl) = do+tcIfaceTickish (IfaceBreakpoint bid fvs) = do   fvs' <- mapM tcIfaceExpr fvs-  return (Breakpoint NoExtField ix [f | Var f <- fvs'] modl)+  return (Breakpoint NoExtField bid [f | Var f <- fvs'])  ------------------------- tcIfaceLit :: Literal -> IfL Literal@@ -1747,10 +1786,9 @@ -}  tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails-tcIdDetails _ _  IfVanillaId = return VanillaId+tcIdDetails _ _  IfVanillaId           = return VanillaId tcIdDetails _ _  (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds-tcIdDetails _ ty IfDFunId-  = return (DFunId (isNewTyCon (classTyCon cls)))+tcIdDetails _ ty IfDFunId              = return (DFunId (isUnaryClass cls))   where     (_, _, cls, _) = tcSplitDFunTy ty @@ -1758,14 +1796,13 @@   = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)                        (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)                        tc-       ; let all_cons = recSelParentCons tc'-             cons_partitioned-                 = conLikesWithFields all_cons [flLabel fl]+       ; let all_cons         = recSelParentCons tc'+             cons_partitioned = conLikesRecSelInfo all_cons [flLabel fl]        ; return (RecSelId-                   { sel_tycon = tc'-                   , sel_naughty = naughty+                   { sel_tycon      = tc'+                   , sel_naughty    = naughty                    , sel_fieldLabel = fl { flSelector = nm }-                   , sel_cons = cons_partitioned }+                   , sel_cons       = cons_partitioned }                        -- Reconstructed here since we don't want Uniques in the Iface file                 ) }   where@@ -2251,9 +2288,10 @@  -- | This function is only used to construct the environment for GHCi, -- so we make up fake locations-tcIfaceImport :: HscEnv -> IfaceImport -> ImportUserSpec-tcIfaceImport _ (IfaceImport spec ImpIfaceAll) = ImpUserSpec spec ImpUserAll-tcIfaceImport _ (IfaceImport spec (ImpIfaceEverythingBut ns)) = ImpUserSpec spec (ImpUserEverythingBut ns)-tcIfaceImport hsc_env (IfaceImport spec (ImpIfaceExplicit gre)) = ImpUserSpec spec (ImpUserExplicit (hydrateGlobalRdrEnv get_GRE_info gre))-  where-    get_GRE_info nm = tyThingGREInfo <$> lookupGlobal hsc_env nm+tcIfaceImport :: IfaceImport -> ImportUserSpec+tcIfaceImport (IfaceImport spec ImpIfaceAll)+  = ImpUserSpec spec ImpUserAll+tcIfaceImport (IfaceImport spec (ImpIfaceEverythingBut ns))+  = ImpUserSpec spec (ImpUserEverythingBut (mkNameSet ns))+tcIfaceImport (IfaceImport spec (ImpIfaceExplicit gre implicit_parents))+  = ImpUserSpec spec (ImpUserExplicit (getDetOrdAvails gre) $ mkNameSet implicit_parents)
compiler/GHC/JS/Opt/Expr.hs view
compiler/GHC/JS/Opt/Simple.hs view
compiler/GHC/Linker/Deps.hs view
@@ -22,7 +22,6 @@  import GHC.Linker.Types -import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM@@ -34,24 +33,17 @@ import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module-import GHC.Unit.Module.ModIface import GHC.Unit.Module.WholeCoreBindings-import GHC.Unit.Module.Deps-import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo  import GHC.Iface.Errors.Types-import GHC.Iface.Errors.Ppr  import GHC.Utils.Misc-import GHC.Unit.Home+import qualified GHC.Unit.Home.Graph as HUG import GHC.Data.Maybe -import Control.Monad import Control.Applicative -import qualified Data.Set as Set-import qualified Data.Map as M import Data.List (isSuffixOf)  import System.FilePath@@ -60,8 +52,6 @@ data LinkDepsOpts = LinkDepsOpts   { ldObjSuffix   :: !String                        -- ^ Suffix of .o files   , ldForceDyn    :: !Bool                          -- ^ Always use .dyn_o?-  , ldOneShotMode :: !Bool                          -- ^ Is the driver in one-shot mode?-  , ldModuleGraph :: !ModuleGraph   , ldUnitEnv     :: !UnitEnv   , ldPprOpts     :: !SDocContext                   -- ^ Rendering options for error messages   , ldUseByteCode :: !Bool                          -- ^ Use bytecode rather than objects@@ -69,8 +59,8 @@   , ldWays        :: !Ways                          -- ^ Enabled ways   , ldFinderCache :: !FinderCache   , ldFinderOpts  :: !FinderOpts-  , ldLoadIface   :: !(SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface))   , ldLoadByteCode :: !(Module -> IO (Maybe Linkable))+  , ldGetDependencies :: !([Module] -> IO ([Module], UniqDSet UnitId))   }  data LinkDeps = LinkDeps@@ -103,7 +93,6 @@        get_link_deps opts pls maybe_normal_osuf span mods - get_link_deps   :: LinkDepsOpts   -> LoaderState@@ -112,31 +101,25 @@   -> [Module]   -> IO LinkDeps get_link_deps opts pls maybe_normal_osuf span mods = do-        -- 1.  Find the dependent home-pkg-modules/packages from each iface++      -- Three step process:++        -- 1. Find the dependent home-pkg-modules/packages from each iface         -- (omitting modules from the interactive package, which is already linked)-      (mods_s, pkgs_s) <--          -- Why two code paths here? There is a significant amount of repeated work-          -- performed calculating transitive dependencies-          -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)-          if ldOneShotMode opts-            then follow_deps (filterOut isInteractiveModule mods)-                              emptyUniqDSet emptyUniqDSet;-            else do-              (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods-              return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs))+      (mods_s, pkgs_s) <- ldGetDependencies opts relevant_mods        let         -- 2.  Exclude ones already linked         --      Main reason: avoid findModule calls in get_linkable-            (mods_needed, links_got) = partitionWith split_mods mods_s-            pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls+        (mods_needed, links_got) = partitionWith split_mods mods_s+        pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls -            split_mods mod =-                let is_linked = lookupModuleEnv (objs_loaded pls) mod-                                <|> lookupModuleEnv (bcos_loaded pls) mod-                in case is_linked of-                     Just linkable -> Right linkable-                     Nothing -> Left mod+        split_mods mod =+            let is_linked = lookupModuleEnv (objs_loaded pls) mod+                            <|> lookupModuleEnv (bcos_loaded pls) mod+            in case is_linked of+                 Just linkable -> Right linkable+                 Nothing -> Left mod          -- 3.  For each dependent module, find its linkable         --     This will either be in the HPT or (in the case of one-shot@@ -150,106 +133,8 @@         , ldNeededUnits     = pkgs_s         }   where-    mod_graph = ldModuleGraph opts-    unit_env  = ldUnitEnv     opts--    -- This code is used in `--make` mode to calculate the home package and unit dependencies-    -- for a set of modules.-    ---    -- It is significantly more efficient to use the shared transitive dependency-    -- calculation than to compute the transitive dependency set in the same manner as oneShot mode.--    -- It is also a matter of correctness to use the module graph so that dependencies between home units-    -- is resolved correctly.-    make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)-    make_deps_loop found [] = found-    make_deps_loop found@(found_units, found_mods) (nk:nexts)-      | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts-      | otherwise =-        case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of-            Just trans_deps ->-              let deps = Set.insert (NodeKey_Module nk) trans_deps-                  -- See #936 and the ghci.prog007 test for why we have to continue traversing through-                  -- boot modules.-                  todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]-              in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)-            Nothing ->-              let (ModNodeKeyWithUid _ uid) = nk-              in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts--    mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)-    (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)--    all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]--    get_mod_info (ModNodeKeyWithUid gwib uid) =-      case lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) of-        Just hmi ->-          let iface = (hm_iface hmi)-              mmod = case mi_hsc_src iface of-                      HsBootFile -> link_boot_mod_error (mi_module iface)-                      _          -> return $ Just (mi_module iface)--          in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$>  mmod-        Nothing -> throwProgramError opts $-          text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid---       -- This code is used in one-shot mode to traverse downwards through the HPT-       -- to find all link dependencies.-       -- The ModIface contains the transitive closure of the module dependencies-       -- within the current package, *except* for boot modules: if we encounter-       -- a boot module, we have to find its real interface and discover the-       -- dependencies of that.  Hence we need to traverse the dependency-       -- tree recursively.  See bug #936, testcase ghci/prog007.-    follow_deps :: [Module]             -- modules to follow-                -> UniqDSet Module         -- accum. module dependencies-                -> UniqDSet UnitId          -- accum. package dependencies-                -> IO ([Module], UniqDSet UnitId) -- result-    follow_deps []     acc_mods acc_pkgs-        = return (uniqDSetToList acc_mods, acc_pkgs)-    follow_deps (mod:mods) acc_mods acc_pkgs-        = do-          mb_iface <- ldLoadIface opts msg mod-          iface <- case mb_iface of-                    Failed err      -> throwProgramError opts $-                      missingInterfaceErrorDiagnostic (ldMsgOpts opts) err-                    Succeeded iface -> return iface--          when (mi_boot iface == IsBoot) $ link_boot_mod_error mod--          let-            pkg = moduleUnit mod-            deps  = mi_deps iface--            pkg_deps = dep_direct_pkgs deps-            (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $-              \case-                (_, GWIB m IsBoot)  -> Left m-                (_, GWIB m NotBoot) -> Right m--            mod_deps' = case ue_homeUnit unit_env of-                          Nothing -> []-                          Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))-            acc_mods'  = case ue_homeUnit unit_env of-                          Nothing -> acc_mods-                          Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps)-            acc_pkgs'  = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)--          case ue_homeUnit unit_env of-            Just home_unit | isHomeUnit home_unit pkg ->  follow_deps (mod_deps' ++ mods)-                                                                      acc_mods' acc_pkgs'-            _ ->  follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))-        where-           msg = text "need to link module" <+> ppr mod <+>-                  text "due to use of Template Haskell"----    link_boot_mod_error :: Module -> IO a-    link_boot_mod_error mod = throwProgramError opts $-            text "module" <+> ppr mod <+>-            text "cannot be linked; it is only available as a boot module"+    unit_env = ldUnitEnv opts+    relevant_mods = filterOut isInteractiveModule mods      no_obj :: Outputable a => a -> IO b     no_obj mod = dieWith opts span $@@ -268,16 +153,16 @@         else homeModInfoObject hmi   <|> homeModInfoByteCode hmi      get_linkable osuf mod      -- A home-package module-        | Just mod_info <- lookupHugByModule mod (ue_home_unit_graph unit_env)-        = adjust_linkable (expectJust "getLinkDeps" (homeModLinkable mod_info))-        | otherwise-        = do    -- It's not in the HPT because we are in one shot mode,-                -- so use the Finder to get a ModLocation...-             case ue_homeUnit unit_env of-              Nothing -> no_obj mod-              Just home_unit -> do-                from_bc <- ldLoadByteCode opts mod-                maybe (fallback_no_bytecode home_unit mod) pure from_bc+      = HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case+          Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info))+          Nothing -> do+           -- It's not in the HPT because we are in one shot mode,+           -- so use the Finder to get a ModLocation...+           case ue_homeUnit unit_env of+            Nothing -> no_obj mod+            Just home_unit -> do+              from_bc <- ldLoadByteCode opts mod+              maybe (fallback_no_bytecode home_unit mod) pure from_bc         where              fallback_no_bytecode home_unit mod = do@@ -319,6 +204,8 @@               CoreBindings WholeCoreBindings {wcb_module} ->                 pprPanic "Unhydrated core bindings" (ppr wcb_module) ++ {- Note [Using Byte Code rather than Object Code for Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -341,7 +228,6 @@ The only other place where the flag is consulted is when enabling code generation with `-fno-code`, which does so to anticipate what decision we will make at the splice point about what we would prefer.- -}  dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a
compiler/GHC/Linker/ExtraObj.hs view
@@ -159,7 +159,7 @@      else return []    where-    unit_state = ue_units unit_env+    unit_state = ue_homeUnitState unit_env     platform   = ue_platform unit_env     link_opts info = hcat         [ -- "link info" section (see Note [LinkInfo section])
compiler/GHC/Linker/Loader.hs view
@@ -17,7 +17,6 @@    , showLoaderState    , getLoaderState    -- * Load & Unload-   , loadExpr    , loadDecls    , loadPackages    , loadModule@@ -29,6 +28,7 @@    , extendLoadedEnv    , deleteFromLoadedEnv    -- * Internals+   , allocateBreakArrays    , rmDupLinkables    , modifyLoaderState    , initLinkDepsOpts@@ -53,14 +53,17 @@ import GHC.Tc.Utils.Monad  import GHC.Runtime.Interpreter+import GHCi.BreakArray import GHCi.RemoteTypes import GHC.Iface.Load-import GHCi.Message (LoadedDLL)+import GHCi.Message (ConInfoTable(..), LoadedDLL) +import GHC.ByteCode.Breakpoints import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types +import GHC.Stack.CCS import GHC.SysTools  import GHC.Types.Basic@@ -77,8 +80,12 @@ import GHC.Utils.TmpFs  import GHC.Unit.Env-import GHC.Unit.External (ExternalPackageState (EPS, eps_iface_bytecode))+import GHC.Unit.Home.ModInfo+import GHC.Unit.External (ExternalPackageState (..)) import GHC.Unit.Module+import GHC.Unit.Module.ModNodeKey+import GHC.Unit.Module.Graph+import GHC.Unit.Module.ModIface import GHC.Unit.State as Packages  import qualified GHC.Data.ShortText as ST@@ -92,12 +99,15 @@ -- Standard libraries import Control.Monad +import Data.Array+import Data.ByteString (ByteString) import qualified Data.Set as Set import Data.Char (isSpace) import qualified Data.Foldable as Foldable import Data.IORef import Data.List (intercalate, isPrefixOf, nub, partition) import Data.Maybe+import Data.Either import Control.Concurrent.MVar import qualified Control.Monad.Catch as MC import qualified Data.List.NonEmpty as NE@@ -112,6 +122,12 @@ #endif  import GHC.Utils.Exception+import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey)+import GHC.Driver.Downsweep+import qualified GHC.Runtime.Interpreter as GHCi+import qualified Data.IntMap.Strict as IM+import qualified Data.Map.Strict as M+import Foreign.Ptr (nullPtr)  -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -170,6 +186,10 @@    , bcos_loaded = emptyModuleEnv    , objs_loaded = emptyModuleEnv    , temp_sos = []+   , linked_breaks = LinkedBreaks+     { breakarray_env = emptyModuleEnv+     , ccs_env        = emptyModuleEnv+     }    }   -- Packages that don't need loading, because the compiler   -- shares them with the interpreted program.@@ -210,12 +230,12 @@     case lookupNameEnv (closure_env (linker_env pls)) name of       Just (_,aa) -> return (pls,(aa, links, pkgs))       Nothing     -> assertPpr (isExternalName name) (ppr name) $-                     do let sym_to_find = nameToCLabel name "closure"-                        m <- lookupClosure interp (unpackFS sym_to_find)+                     do let sym_to_find = IClosureSymbol name+                        m <- lookupClosure interp sym_to_find                         r <- case m of                           Just hvref -> mkFinalizedHValue interp hvref                           Nothing -> linkFail "GHC.Linker.Loader.loadName"-                                       (unpackFS sym_to_find)+                                       (ppr sym_to_find)                         return (pls,(r, links, pkgs))  loadDependencies@@ -589,60 +609,12 @@           , "Try using a dynamic library instead."           ] --{- **********************************************************************--                        Link a byte-code expression--  ********************************************************************* -}---- | Load a single expression, /including/ first loading packages and--- modules that this expression depends on.------ Raises an IO exception ('ProgramError') if it can't find a compiled--- version of the dependents to load.----loadExpr :: Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue-loadExpr interp hsc_env span root_ul_bco = do-  -- Initialise the linker (if it's not been done already)-  initLoaderState interp hsc_env--  -- Take lock for the actual work.-  modifyLoaderState interp $ \pls0 -> do-    -- Load the packages and modules required-    (pls, ok, _, _) <- loadDependencies interp hsc_env pls0 span needed_mods-    if failed ok-      then throwGhcExceptionIO (ProgramError "")-      else do-        -- Load the expression itself-        -- Load the necessary packages and linkables-        let le = linker_env pls-            bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]-        resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix root_ul_bco-        [root_hvref] <- createBCOs interp [resolved]-        fhv <- mkFinalizedHValue interp root_hvref-        return (pls, fhv)-  where-     free_names = uniqDSetToList (bcoFreeNames root_ul_bco)--     needed_mods :: [Module]-     needed_mods = [ nameModule n | n <- free_names,-                     isExternalName n,      -- Names from other modules-                     not (isWiredInName n)  -- Exclude wired-in names-                   ]                        -- (see note below)-        -- Exclude wired-in names because we may not have read-        -- their interface files, so getLinkDeps will fail-        -- All wired-in names are in the base package, which we link-        -- by default, so we can safely ignore them here.- initLinkDepsOpts :: HscEnv -> LinkDepsOpts initLinkDepsOpts hsc_env = opts   where     opts = LinkDepsOpts             { ldObjSuffix   = objectSuf dflags             , ldForceDyn    = sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags-            , ldOneShotMode = isOneShot (ghcMode dflags)-            , ldModuleGraph = hsc_mod_graph hsc_env             , ldUnitEnv     = hsc_unit_env hsc_env             , ldPprOpts     = initSDocContext dflags defaultUserStyle             , ldFinderCache = hsc_FC hsc_env@@ -650,19 +622,60 @@             , ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags             , ldMsgOpts     = initIfaceMessageOpts dflags             , ldWays        = ways dflags-            , ldLoadIface+            , ldGetDependencies = get_reachable_nodes hsc_env             , ldLoadByteCode             }     dflags = hsc_dflags hsc_env-    ldLoadIface msg mod = initIfaceCheck (text "loader") hsc_env-                          $ loadInterface msg mod (ImportByUser NotBoot)      ldLoadByteCode mod = do+      _ <- initIfaceLoad hsc_env $+             loadInterface (text "get_reachable_nodes" <+> parens (ppr mod))+                 mod ImportBySystem       EPS {eps_iface_bytecode} <- hscEPS hsc_env       sequence (lookupModuleEnv eps_iface_bytecode mod)  +get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId)+get_reachable_nodes hsc_env mods +  -- Fallback case if the ModuleGraph has not been initialised by the user.+  -- This can happen if is the user is loading plugins or doing something else very+  -- early in the compiler pipeline.+  | isEmptyMG (hsc_mod_graph hsc_env)+  = do+      mg <- downsweepInstalledModules hsc_env mods+      go mg++  | otherwise+  = go (hsc_mod_graph hsc_env)++  where+    unit_env = hsc_unit_env hsc_env+    mkModuleNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)++    hmgModKey mg m+      | let k = NodeKey_Module (mkModuleNk m)+      , mgMember mg k = k+      | otherwise = NodeKey_ExternalUnit (moduleUnitId m)++    -- The main driver for getting dependencies, which calls the given+    -- functions to compute the reachable nodes.+    go :: ModuleGraph -> IO ([Module], UniqDSet UnitId)+    go mg = do+        let mod_keys = map (hmgModKey mg) mods+            all_reachable = mod_keys ++ map mkNodeKey (mgReachableLoop mg mod_keys)+        (mods_s, pkgs_s) <- partitionEithers <$> mapMaybeM get_mod_info all_reachable+        return (mods_s, mkUniqDSet pkgs_s)++    get_mod_info :: NodeKey -> IO (Maybe (Either Module UnitId))+    get_mod_info (NodeKey_Module m@(ModNodeKeyWithUid gwib uid)) =+      lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) >>= \case+        Just hmi -> return $ Just (Left  (mi_module (hm_iface hmi)))+        Nothing -> return (Just (Left (mnkToModule m)))+    get_mod_info (NodeKey_ExternalUnit uid) = return (Just (Right uid))+    get_mod_info _ = return Nothing++ {- **********************************************************************                Loading a Decls statement@@ -687,14 +700,22 @@         else do           -- Link the expression itself           let le  = linker_env pls-              le2 = le { itbl_env = foldl' (\acc cbc -> plusNameEnv acc (bc_itbls cbc)) (itbl_env le) cbcs-                       , addr_env = foldl' (\acc cbc -> plusNameEnv acc (bc_strs cbc)) (addr_env le) cbcs }+          let lb  = linked_breaks pls+          le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs)+          le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs+          le2_breakarray_env <- allocateBreakArrays interp (breakarray_env lb) (catMaybes $ map bc_breaks cbcs)+          le2_ccs_env        <- allocateCCS         interp (ccs_env lb)        (catMaybes $ map bc_breaks cbcs)+          let le2 = le { itbl_env = le2_itbl_env+                       , addr_env = le2_addr_env }+          let lb2 = lb { breakarray_env = le2_breakarray_env+                       , ccs_env = le2_ccs_env }            -- Link the necessary packages and linkables-          new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs+          new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs           nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings           let ce2  = extendClosureEnv (closure_env le2) nms_fhvs-              !pls2 = pls { linker_env = le2 { closure_env = ce2 } }+              !pls2 = pls { linker_env = le2 { closure_env = ce2 }+                          , linked_breaks = lb2 }           return (pls2, (nms_fhvs, links_needed, units_needed))   where     cbcs = linkableBCOs linkable@@ -873,7 +894,7 @@     m <- loadDLL interp soFile     case m of       Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos }-      Left err -> linkFail msg err+      Left err -> linkFail msg (text err)   where     msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" @@ -910,11 +931,15 @@               le1 = linker_env pls-            ie2 = foldr plusNameEnv (itbl_env le1) (map bc_itbls cbcs)-            ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs)-            le2 = le1 { itbl_env = ie2, addr_env = ae2 }+            lb1 = linked_breaks pls+        ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs)+        ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs+        be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs)+        ce2 <- allocateCCS         interp (ccs_env lb1)        (catMaybes $ map bc_breaks cbcs)+        let le2 = le1 { itbl_env = ie2, addr_env = ae2 }+        let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 } -        names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs+        names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs          -- We only want to add the external ones to the ClosureEnv         let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs@@ -925,19 +950,21 @@         new_binds <- makeForeignNamedHValueRefs interp to_add          let ce2 = extendClosureEnv (closure_env le2) new_binds-        return $! pls1 { linker_env = le2 { closure_env = ce2 } }+        return $! pls1 { linker_env = le2 { closure_env = ce2 }+                       , linked_breaks = lb2 }  -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp              -> PkgsLoaded              -> LinkerEnv+             -> LinkedBreaks              -> [CompiledByteCode]              -> IO [(Name,HValueRef)]                         -- The returned HValueRefs are associated 1-1 with                         -- the incoming unlinked BCOs.  Each gives the                         -- value of the corresponding unlinked BCO -linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []+linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods []  where   fun CompiledByteCode{..} inner accum =     inner (Foldable.toList bc_bcos : accum)@@ -947,7 +974,7 @@     let flat = [ bco | bcos <- mods, bco <- bcos ]         names = map unlinkedBCOName flat         bco_ix = mkNameEnv (zip names [0..])-    resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix bco | bco <- flat ]+    resolved <- sequence [ linkBCO interp pkgs_loaded le lb bco_ix bco | bco <- flat ]     hvrefs <- createBCOs interp resolved     return (zip names hvrefs) @@ -957,6 +984,11 @@ makeForeignNamedHValueRefs interp bindings =   mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp hvref) bindings +linkITbls :: Interp -> ItblEnv -> [(Name, ConInfoTable)] -> IO ItblEnv+linkITbls interp = foldlM $ \env (nm, itbl) -> do+  r <- interpCmd interp $ MkConInfoTable itbl+  evaluate $ extendNameEnv env nm (nm, ItblPtr r)+ {- **********************************************************************                  Unload some object modules@@ -1040,10 +1072,14 @@       keep_name n = isExternalName n &&                     nameModule n `elemModuleEnv` remaining_bcos_loaded -      !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env,-                       bcos_loaded = remaining_bcos_loaded,-                       objs_loaded = remaining_objs_loaded }+      keep_mod :: Module -> Bool+      keep_mod m = m `elemModuleEnv` remaining_bcos_loaded +      !new_pls = pls { linker_env    = filterLinkerEnv keep_name linker_env,+                       linked_breaks = filterLinkedBreaks keep_mod linked_breaks,+                       bcos_loaded   = remaining_bcos_loaded,+                       objs_loaded   = remaining_objs_loaded }+   return new_pls   where     unloadObjs :: Linkable -> IO ()@@ -1613,3 +1649,84 @@  maybePutStrLn :: Logger -> String -> IO () maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n")++-- | see Note [Generating code for top-level string literal bindings]+allocateTopStrings ::+  Interp -> [(Name, ByteString)] -> AddrEnv -> IO AddrEnv+allocateTopStrings interp topStrings prev_env = do+  let (bndrs, strings) = unzip topStrings+  ptrs <- interpCmd interp $ MallocStrings strings+  evaluate $ extendNameEnvList prev_env (zipWith mk_entry bndrs ptrs)+  where+    mk_entry nm ptr = (nm, (nm, AddrPtr ptr))++-- | Given a list of 'InternalModBreaks' collected from a list of+-- 'CompiledByteCode', allocate the 'BreakArray' used to trigger breakpoints.+allocateBreakArrays ::+  Interp ->+  ModuleEnv (ForeignRef BreakArray) ->+  [InternalModBreaks] ->+  IO (ModuleEnv (ForeignRef BreakArray))+allocateBreakArrays interp =+  foldlM+    ( \be0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks {..}} -> do+        -- If no BreakArray is assigned to this module yet, create one+        if not $ elemModuleEnv modBreaks_module be0 then do+          let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo+          breakArray <- GHCi.newBreakArray interp count+          evaluate $ extendModuleEnv be0 modBreaks_module breakArray+        else+          return be0+    )++-- | Given a list of 'InternalModBreaks' collected from a list+-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is+-- enabled.+--+-- Note that the resulting arrays are indexed by 'BreakInfoIndex' (internal+-- breakpoint index), not by tick index+allocateCCS ::+  Interp ->+  ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre)) ->+  [InternalModBreaks] ->+  IO (ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre)))+allocateCCS interp ce mbss+  | interpreterProfiled interp = do+      -- 1. Create a mapping from source BreakpointId to CostCentre ptr+      ccss <- M.unions <$> mapM+        ( \InternalModBreaks{imodBreaks_modBreaks=ModBreaks{..}} -> do+            ccs <- {- one ccs ptr per tick index -}+              mkCostCentres+                interp+                (moduleNameString $ moduleName modBreaks_module)+                (elems modBreaks_ccs)+            return $ M.fromList $+              zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..]+        )+        mbss+      -- 2. Create an array with one element for every InternalBreakpointId,+      --    where every element has the CCS for the corresponding BreakpointId+      foldlM+        (\ce0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks{..}} -> do+            if not $ elemModuleEnv modBreaks_module ce then do+              let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo+              let ccs = IM.map+                    (\info ->+                        fromMaybe (toRemotePtr nullPtr)+                          (M.lookup (either internalBreakLoc id (cgb_tick_id info)) ccss)+                    )+                    imodBreaks_breakInfo+              assertPpr (count == length ccs)+                (text "expected CgBreakInfo map to have one entry per valid ix") $+                evaluate $+                  extendModuleEnv ce0 modBreaks_module $+                    listArray+                      (0, count)+                      (IM.elems ccs)+            else+              return ce0+        )+        ce+        mbss++  | otherwise = pure ce
compiler/GHC/Linker/Static.hs view
@@ -71,7 +71,7 @@ linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do     let platform   = ue_platform unit_env-        unit_state = ue_units unit_env+        unit_state = ue_homeUnitState unit_env         toolSettings' = toolSettings dflags         verbFlags = getVerbFlags dflags         arch_os   = platformArchOS platform
compiler/GHC/Plugins.hs view
@@ -202,7 +202,8 @@ -- ensures everything in that session will get the same name cache. thNameToGhcNameIO :: NameCache -> TH.Name -> IO (Maybe Name) thNameToGhcNameIO cache th_name-  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)+  =  do { let listTuplePuns = True -- conservative assumption+        ; names <- mapMaybeM lookup (thRdrNameGuesses listTuplePuns th_name)           -- Pick the first that works           -- E.g. reify (mkName "A") will pick the class A in preference           -- to the data constructor A
compiler/GHC/Rename/Bind.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -22,7 +20,7 @@    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,     -- Other bindings-   rnMethodBinds, renameSigs,+   rnMethodBinds, renameSigs, bindRuleBndrs,    rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,    makeMiniFixityEnv, MiniFixityEnv, emptyMiniFixityEnv,    HsSigCtxt(..),@@ -46,32 +44,37 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( mapFvRn-                        , checkDupRdrNames-                        , warnUnusedLocalBinds-                        , checkUnusedRecordWildcard-                        , checkDupAndShadowedNames, bindLocalNamesFV-                        , addNoNestedForallsContextsErr, checkInferredVars )+import GHC.Rename.Utils import GHC.Driver.DynFlags-import GHC.Unit.Module++import GHC.Data.BooleanFormula ( bfTraverse )+import GHC.Data.Graph.Directed ( SCC(..) )+import GHC.Data.Maybe          ( orElse, mapMaybe )+import GHC.Data.OrdList+import GHC.Data.List.SetOps    ( findDupsEq )++ import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set-import GHC.Types.Name.Reader ( RdrName, rdrNameOcc )+import GHC.Types.Name.Reader import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc-import GHC.Data.List.SetOps    ( findDupsEq ) import GHC.Types.Basic         ( RecFlag(..), TypeOrKind(..) )-import GHC.Data.Graph.Directed ( SCC(..) )++import GHC.Types.CompleteMatch+import GHC.Types.Hint ( SigLike(..) )+import GHC.Types.Unique.DSet ( mkUniqDSet )+import GHC.Types.Unique.Set++import GHC.Unit.Module+ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Types.CompleteMatch-import GHC.Types.Unique.Set-import GHC.Data.Maybe          ( orElse, mapMaybe )-import GHC.Data.OrdList+ import qualified GHC.LanguageExtensions as LangExt  import Language.Haskell.Syntax.Basic (FieldLabelString(..))@@ -79,7 +82,6 @@ import Control.Monad import Data.List          ( partition ) import Data.List.NonEmpty ( NonEmpty(..) )-import GHC.Types.Unique.DSet (mkUniqDSet)  {- -- ToDo: Put the annotations into the monad, so that they arrive in the proper@@ -336,7 +338,8 @@        -- Update the TcGblEnv with renamed COMPLETE pragmas from the current        -- module, for pattern irrefutability checking in do notation.        ; let localCompletePrags = localCompletePragmas sigs'-       ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags}) $+       ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags+                                      , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags }) $     do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn sigs')) mbinds        ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus @@ -454,7 +457,7 @@   = do       -- we don't actually use the FV processing of rnPatsAndThen here       (pat',pat'_fvs) <- rnBindPat name_maker pat-      (pat_mult', mult'_fvs) <- rnHsMultAnn pat_mult+      (pat_mult', mult'_fvs) <- rnHsMultAnnWith (rnLHsType PatCtx) pat_mult       return (bind { pat_lhs = pat', pat_ext = pat'_fvs `plusFV` mult'_fvs, pat_mult = pat_mult' })                 -- We temporarily store the pat's FVs in bind_fvs;                 -- gets updated to the FVs of the whole bind@@ -469,7 +472,7 @@   | isTopRecNameMaker name_maker   = do { addLocM checkConName rdrname        ; name <--           lookupLocatedTopConstructorRnN rdrname -- Should be in scope already+           lookupLocatedTopBndrRnN WL_ConLike rdrname -- Should be in scope already        ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }    | otherwise  -- Pattern synonym, not at top level@@ -741,16 +744,6 @@        DataNamespaceSpecifier{} -> env { mfe_data_level_names = (extendFsEnv mfe_data_level_names fs fix_item)} ---- | Multiplicity annotations are a simple wrapper around types. As such,--- renaming them is a straightforward wrapper around 'rnLHsType'.-rnHsMultAnn :: HsMultAnn GhcPs -> RnM (HsMultAnn GhcRn, FreeVars)-rnHsMultAnn (HsNoMultAnn _) = return (HsNoMultAnn noExtField, emptyFVs)-rnHsMultAnn (HsPct1Ann _) = return (HsPct1Ann noExtField, emptyFVs)-rnHsMultAnn (HsMultAnn _ p) = do-  (p', freeVars') <- rnLHsType PatCtx p-  return $ (HsMultAnn noExtField p', freeVars')- {- ********************************************************************* *                                                                      *                 Pattern synonym bindings@@ -775,10 +768,10 @@          -- so that the binding locations are reported          -- from the left-hand side             case details of-               PrefixCon _ vars ->+               PrefixCon vars ->                    do { checkDupRdrNames vars                       ; names <- mapM lookupPatSynBndr vars-                      ; return ( (pat', PrefixCon noTypeArgs names)+                      ; return ( (pat', PrefixCon names)                                , mkFVs (map unLoc names)) }                InfixCon var1 var2 ->                    do { checkDupRdrNames [var1, var2]@@ -789,7 +782,7 @@                                , mkFVs (map unLoc [name1, name2])) }                RecCon vars ->                    do { checkDupRdrNames (map (foLabel . recordPatSynField) vars)-                      ; fls <- lookupConstructorFields name+                      ; fls <- lookupConstructorFields $ noUserRdr name                       ; let fld_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ]                       ; let rnRecordPatSynField                               (RecordPatSynField { recordPatSynField  = visible@@ -955,7 +948,8 @@        ; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs              bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds')              sig_ctxt | is_cls_decl = ClsDeclCtxt cls-                      | otherwise   = InstDeclCtxt bound_nms+                      | otherwise   = InstDeclCtxt (mkOccEnv [ (nameOccName n, n)+                                                             | n <- nonDetEltsUniqSet bound_nms ])        ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags        ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $                                       renameSigs sig_ctxt other_sigs@@ -963,7 +957,8 @@         -- Update the TcGblEnv with renamed COMPLETE pragmas from the current        -- module, for pattern irrefutability checking in do notation.-       ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags}) $+       ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags+                                      , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags}) $     do {        -- Rename the bindings RHSs.  Again there's an issue about whether the        -- type variables from the class/instance head are in scope.@@ -1022,7 +1017,7 @@                 -> RnM (LHsBindsLR GhcRn GhcPs) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest   = setSrcSpanA loc $ do-    do { sel_name <- wrapLocMA (lookupInstDeclBndr cls (text "method")) name+    do { sel_name <- wrapLocMA (lookupInstDeclBndr cls MethodOfClass) name                      -- We use the selector name as the binder        ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField }        ; return (L loc bind' : rest ) }@@ -1070,19 +1065,10 @@         ; return (good_sigs, sig_fvs) }  ------------------------- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory--- because this won't work for:---      instance Foo T where---        {-# INLINE op #-}---        Baz.op = ...--- We'll just rename the INLINE prag to refer to whatever other 'op'--- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)--- Doesn't seem worth much trouble to sort this.- renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) renameSig ctxt sig@(TypeSig _ vs ty)-  = do  { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs-        ; let doc = TypeSigCtx (ppr_sig_bndrs vs)+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+        ; let doc = TypeSigCtx vs         ; (new_ty, fvs) <- rnHsSigWcType doc ty         ; return (TypeSig noAnn new_vs new_ty, fvs) } @@ -1090,13 +1076,12 @@   = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures         ; when (is_deflt && not defaultSigs_on) $           addErr (TcRnUnexpectedDefaultSig sig)-        ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs+        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs         ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty         ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }   where-    (v1:_) = vs-    ty_ctxt = GenericCtx (text "a class method signature for"-                          <+> quotes (ppr v1))+    v1:|_ = expectNonEmpty vs+    ty_ctxt = ClassMethodSigCtx v1  renameSig _ (SpecInstSig (_, src) ty)   = do  { checkInferredVars doc ty@@ -1117,19 +1102,24 @@ -- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig ctxt sig@(SpecSig _ v tys inl)   = do  { new_v <- case ctxt of-                     TopSigCtxt {} -> lookupLocatedOccRn v-                     _             -> lookupSigOccRnN ctxt sig v+                     TopSigCtxt {} -> lookupLocatedOccRn WL_TermVariable v+                     _             -> lookupSigOccRn ctxt sig v         ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys         ; return (SpecSig noAnn new_v new_ty inl, fvs) }   where-    ty_ctxt = GenericCtx (text "a SPECIALISE signature for"-                          <+> quotes (ppr v))     do_one (tys,fvs) ty-      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty+      = do { (new_ty, fvs_ty) <- rnHsSigType (SpecialiseSigCtx v) TypeLevel ty            ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } +renameSig _ctxt (SpecSigE _ bndrs spec_e inl)+  = do { fn_rdr <- checkSpecESigShape spec_e+       ; fn_name <- lookupOccRn WL_TermVariable fn_rdr  -- Checks that the head isn't forall-bound+       ; bindRuleBndrs (SpecECtx fn_rdr) bndrs $ \_ bndrs' ->+         do { (spec_e', fvs) <- rnLExpr spec_e+            ; return (SpecSigE fn_name bndrs' spec_e' inl, fvs) } }+ renameSig ctxt sig@(InlineSig _ v s)-  = do  { new_v <- lookupSigOccRnN ctxt sig v+  = do  { new_v <- lookupSigOccRn ctxt sig v         ; return (InlineSig noAnn new_v s, emptyFVs) }  renameSig ctxt (FixSig _ fsig)@@ -1137,35 +1127,50 @@         ; return (FixSig noAnn new_fsig, emptyFVs) }  renameSig ctxt sig@(MinimalSig (_, s) (L l bf))-  = do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf+  = do new_bf <- bfTraverse (lookupSigOccRn ctxt sig) bf        return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs)  renameSig ctxt sig@(PatSynSig _ vs ty)-  = do  { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs         ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty         ; return (PatSynSig noAnn new_vs ty', fvs) }   where-    ty_ctxt = GenericCtx (text "a pattern synonym signature for"-                          <+> ppr_sig_bndrs vs)+    ty_ctxt = PatSynSigCtx vs  renameSig ctxt sig@(SCCFunSig (_, st) v s)-  = do  { new_v <- lookupSigOccRnN ctxt sig v+  = do  { new_v <- lookupSigOccRn ctxt sig v         ; return (SCCFunSig (noAnn, st) new_v s, emptyFVs) }  -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn-renameSig _ctxt sig@(CompleteMatchSig (_, s) bf mty)-  = do new_bf <- traverse lookupLocatedOccRn bf-       new_mty  <- traverse lookupLocatedOccRn mty+renameSig _ctxt (CompleteMatchSig (_, s) bf mty)+  = do new_bf <- traverse (lookupLocatedOccRn WL_ConLike) bf+       new_mty  <- traverse (lookupLocatedOccRn WL_TyCon) mty         this_mod <- fmap tcg_mod getGblEnv+       let rn_sig = CompleteMatchSig (noAnn, s) new_bf new_mty        unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $          -- Why 'any'? See Note [Orphan COMPLETE pragmas]-         addErrCtxt (text "In" <+> ppr sig) $ failWithTc TcRnOrphanCompletePragma+         addErrCtxt (SigCtxt rn_sig) $ failWithTc TcRnOrphanCompletePragma -       return (CompleteMatchSig (noAnn, s) new_bf new_mty, emptyFVs)+       return (rn_sig, emptyFVs)  +checkSpecESigShape :: LHsExpr GhcPs -> RnM RdrName+-- Checks the shape of a SPECIALISE+-- That it looks like  (f a1 .. an [ :: ty ])+checkSpecESigShape spec_e = go_l spec_e+  where+    go_l (L _ e) = go e++    go :: HsExpr GhcPs -> RnM RdrName+    go (ExprWithTySig _ fn _) = go_l fn+    go (HsApp _ fn _)         = go_l fn+    go (HsAppType _ fn _)     = go_l fn+    go (HsVar _ (L _ fn))     = return fn+    go (HsPar _ e)            = go_l e+    go _ = failWithTc (TcRnSpecSigShape spec_e)+ {- Note [Orphan COMPLETE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1188,9 +1193,6 @@ complexity of supporting them properly doesn't seem worthwhile. -} -ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc-ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)- okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool okHsSig ctxt (L _ sig)   = case (sig, ctxt) of@@ -1211,10 +1213,8 @@      (InlineSig {}, HsBootCtxt {}) -> False      (InlineSig {}, _)             -> True -     (SpecSig {}, TopSigCtxt {})    -> True-     (SpecSig {}, LocalBindCtxt {}) -> True-     (SpecSig {}, InstDeclCtxt {})  -> True-     (SpecSig {}, _)                -> False+     (SpecSig {},  ctxt) -> ok_spec_ctxt ctxt+     (SpecSigE {}, ctxt) -> ok_spec_ctxt ctxt       (SpecInstSig {}, InstDeclCtxt {}) -> True      (SpecInstSig {}, _)               -> False@@ -1232,6 +1232,12 @@      (XSig {}, InstDeclCtxt {}) -> True      (XSig {}, _)               -> False +ok_spec_ctxt ::HsSigCtxt -> Bool+-- Contexts where SPECIALISE can occur+ok_spec_ctxt (TopSigCtxt {})    = True+ok_spec_ctxt (LocalBindCtxt {}) = True+ok_spec_ctxt (InstDeclCtxt {})  = True+ok_spec_ctxt _                  = False  ------------------- findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)]@@ -1283,7 +1289,55 @@   -- backwards wrt. declaration order. So we reverse them here, because it makes   -- a difference for incomplete match suggestions. +bindRuleBndrs :: HsDocContext -> RuleBndrs GhcPs+              -> ([Name] -> RuleBndrs GhcRn -> RnM (a,FreeVars))+              -> RnM (a,FreeVars)+bindRuleBndrs doc (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside+  = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs+       ; checkDupRdrNames rdr_names_w_loc+       ; checkShadowedRdrNames rdr_names_w_loc+       ; names <- newLocalBndrsRn rdr_names_w_loc+       ; bindRuleTyVars doc tyvs             $ \ tyvs' ->+         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->+         thing_inside names (RuleBndrs { rb_ext = noExtField+                                       , rb_tyvs = tyvs', rb_tmvs = tmvs' }) }+  where+    get_var :: RuleBndr GhcPs -> LocatedN RdrName+    get_var (RuleBndrSig _ v _) = v+    get_var (RuleBndr _ v)      = v ++bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs+               -> [LRuleBndr GhcPs] -> [Name]+               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))+               -> RnM (a, FreeVars)+bindRuleTmVars doc tyvs vars names thing_inside+  = go vars names $ \ vars' ->+    bindLocalNamesFV names (thing_inside vars')+  where+    go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside+      = go vars ns $ \ vars' ->+        thing_inside (L l (RuleBndr noAnn (L loc n)) : vars')++    go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)+       (n : ns) thing_inside+      = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' ->+        go vars ns $ \ vars' ->+        thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars')++    go [] [] thing_inside = thing_inside []+    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)++    bind_free_tvs = case tyvs of Nothing -> AlwaysBind+                                 Just _  -> NeverBind++bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]+               -> (Maybe [LHsTyVarBndr () GhcRn]  -> RnM (b, FreeVars))+               -> RnM (b, FreeVars)+bindRuleTyVars doc (Just bndrs) thing_inside+  = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just)+bindRuleTyVars _ _ thing_inside = thing_inside Nothing+ {- ************************************************************************ *                                                                      *@@ -1464,9 +1518,8 @@       = setSrcSpanA name_loc $                     -- This lookup will fail if the name is not defined in the                     -- same binding group as this fixity declaration.-        do names <- lookupLocalTcNames sig_ctxt what ns_spec rdr_name+        do names <- lookupLocalTcNames sig_ctxt SigLikeFixitySig ns_spec rdr_name            return [ L name_loc name | (_, name) <- names ]-    what = text "fixity signature"  {- ************************************************************************
compiler/GHC/Rename/Env.hs view
@@ -14,8 +14,7 @@ module GHC.Rename.Env (         newTopSrcBinder, -        lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn,-        lookupLocatedTopConstructorRn, lookupLocatedTopConstructorRnN,+        lookupLocatedTopBndrRnN, lookupTopBndrRn,          lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField,         lookupLocatedOccRnNone,@@ -23,7 +22,7 @@         lookupLocalOccRn_maybe, lookupInfoOccRn,         lookupLocalOccThLvl_maybe, lookupLocalOccRn,         lookupTypeOccRn,-        lookupGlobalOccRn, lookupGlobalOccRn_maybe,+        lookupGlobalOccRn_maybe,          lookupExprOccRn,         lookupRecFieldOcc,@@ -34,7 +33,7 @@         ChildLookupResult(..),         lookupSubBndrOcc_helper, -        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN,+        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,         lookupSigCtxtOccRn,          lookupInstDeclBndr, lookupFamInstName,@@ -51,8 +50,7 @@         lookupIfThenElse,          -- QualifiedDo-        lookupQualifiedDoExpr, lookupQualifiedDo,-        lookupQualifiedDoName, lookupNameWithQualifier,+        lookupQualifiedDo, lookupQualifiedDoName, lookupNameWithQualifier,          -- Constructing usage information         DeprecationWarnings(..),@@ -82,7 +80,6 @@ import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Types.Hint-import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Core.ConLike@@ -115,7 +112,7 @@ import Control.Monad import Data.Either      ( partitionEithers ) import Data.Function    ( on )-import Data.List        ( find, partition, groupBy, sortBy )+import Data.List        ( find, partition, sortBy ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semi import System.IO.Unsafe ( unsafePerformIO )@@ -241,8 +238,8 @@                 -- Binders should not be qualified; if they are, and with a different                 -- module name, we get a confusing "M.T is not in scope" error later -        ; stage <- getStage-        ; if isBrackStage stage then+        ; level <- getThLevel+        ; if isBrackLevel level then                 -- We are inside a TH bracket, so make an *Internal* name                 -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names              do { uniq <- newUnique@@ -277,7 +274,7 @@  -- Can be made to not be exposed -- Only used unwrapped in rnAnnProvenance-lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name+lookupTopBndrRn :: WhatLooking -> RdrName -> RnM (WithUserRdr 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:@@ -289,7 +286,7 @@ -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one. lookupTopBndrRn which_suggest rdr_name =-  lookupExactOrOrig rdr_name greName $+  lookupExactOrOrig rdr_name (WithUserRdr rdr_name . greName) $     do  {  -- Check for operators in type or class declarations            -- See Note [Type and class operator definitions]           let occ = rdrNameOcc rdr_name@@ -297,24 +294,17 @@                (do { op_ok <- xoptM LangExt.TypeOperators                    ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) })         ; env <- getGlobalRdrEnv-        ; case filter isLocalGRE (lookupGRE env $ LookupRdrName rdr_name $ RelevantGREsFOS WantNormal) of+        ; WithUserRdr rdr_name <$>+          case filter isLocalGRE (lookupGRE env $ LookupRdrName rdr_name $ RelevantGREsFOS WantNormal) of             [gre] -> return (greName gre)             _     -> do -- Ambiguous (can't happen) or unbound                         traceRn "lookupTopBndrRN fail" (ppr 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 WL_Anything)--lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name)-lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything)+lookupLocatedTopBndrRnN :: WhatLooking -> LocatedN RdrName -> RnM (LocatedN Name)+lookupLocatedTopBndrRnN what_look =+  wrapLocMA (fmap getName . lookupTopBndrRn what_look)  -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see@@ -386,7 +376,7 @@            -- Ugh!  See Note [Template Haskell ambiguity] }  ------------------------------------------------lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name+lookupInstDeclBndr :: Name -> Subordinate -> RdrName -> RnM Name -- This is called on the method name on the left-hand side of an -- instance declaration binding. eg.  instance Functor T where --                                       fmap = ...@@ -401,7 +391,7 @@ -- -- The "what" parameter says "method" or "associated type", -- depending on what we are looking up-lookupInstDeclBndr cls what rdr+lookupInstDeclBndr cls what_subordinate rdr   = do { when (isQual rdr)               (addErr (badQualBndrErr rdr))                 -- In an instance decl you aren't allowed@@ -413,13 +403,11 @@                                 -- warnings when a deprecated class                                 -- method is defined. We only warn                                 -- when it's used-                          cls doc rdr+                          (ParentGRE cls (IAmTyCon ClassFlavour)) what_subordinate rdr        ; case mb_name of-           Left err -> do { addErr (mkTcRnNotInScope rdr err)+           Left err -> do { addErr $ TcRnNotInScope err rdr                           ; return (mkUnboundNameRdr rdr) }            Right nm -> return nm }-  where-    doc = what <+> text "of class" <+> quotes (ppr cls)  ----------------------------------------------- lookupFamInstName :: Maybe Name -> LocatedN RdrName@@ -427,22 +415,22 @@ -- Used for TyData and TySynonym family instances only, -- See Note [Family instance binders] lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f GHC.Rename.Bind.rnMethodBind-  = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr+  = wrapLocMA (lookupInstDeclBndr cls AssociatedTypeOfClass) tc_rdr lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*-  = lookupLocatedOccRnConstr tc_rdr+  = lookupLocatedOccRn WL_TyCon tc_rdr  ------------------------------------------------lookupConstructorFields :: HasDebugCallStack => Name -> RnM [FieldLabel]+lookupConstructorFields :: HasDebugCallStack => WithUserRdr Name -> RnM [FieldLabel] lookupConstructorFields = fmap conInfoFields . lookupConstructorInfo  -- | Look up the arity and record fields of a constructor.-lookupConstructorInfo :: HasDebugCallStack => Name -> RnM ConInfo-lookupConstructorInfo con_name+lookupConstructorInfo :: HasDebugCallStack => WithUserRdr Name -> RnM ConInfo+lookupConstructorInfo qcon@(WithUserRdr _ con_name)   = do { info <- lookupGREInfo_GRE con_name        ; case info of             IAmConLike con_info -> return con_info             UnboundGRE          -> return $ ConInfo (ConIsData []) ConHasPositionalArgs-            IAmTyCon {}         -> failIllegalTyCon WL_Constructor con_name+            IAmTyCon {}         -> failIllegalTyCon WL_ConLike qcon             _ -> pprPanic "lookupConstructorInfo: not a ConLike" $                       vcat [ text "name:" <+> ppr con_name ]        }@@ -457,7 +445,7 @@           FoundExactOrOrig gre -> return $ res gre           NotExactOrOrig       -> k           ExactOrOrigError e   ->-            do { addErr (mkTcRnNotInScope rdr_name e)+            do { addErr $ TcRnNotInScope e rdr_name                ; return $ res (mkUnboundGRERdr rdr_name) } }  -- Variant of 'lookupExactOrOrig' that does not report an error@@ -529,18 +517,19 @@ -- If -XDisambiguateRecordFields is off, then we will pass 'Nothing' for the -- 'DataCon' 'Name', i.e. we don't use the data constructor for disambiguation. -- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors].-lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual-                                -- Just con => use data con to disambiguate+lookupRecFieldOcc :: Maybe (WithUserRdr Name)+                       -- Nothing  => just look it up as usual+                       -- Just con => use data con to disambiguate                   -> RdrName                   -> RnM Name lookupRecFieldOcc mb_con rdr_name-  | Just con <- mb_con+  | Just (WithUserRdr _ con) <- mb_con   , isUnboundName con  -- Avoid error cascade   = return $ mk_unbound_rec_fld con-  | Just con <- mb_con+  | Just qcon@(WithUserRdr _ con) <- mb_con   = do { let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name)        ; mb_nm <- lookupExactOrOrig rdr_name ensure_recfld $  -- See Note [Record field names and Template Haskell]-            do { flds <- lookupConstructorFields con+            do { flds <- lookupConstructorFields qcon                ; env <- getGlobalRdrEnv                ; let mb_gre = do fl <- find ((== lbl) . flLabel) flds                                  -- We have the label, now check it is in scope.  If@@ -564,11 +553,18 @@           ; Just nm -> return nm } }    | otherwise  -- Can't use the data constructor to disambiguate-  = lookupGlobalOccRn' (RelevantGREsFOS WantField) rdr_name-    -- This use of Global is right as we are looking up a selector,-    -- which can only be defined at the top level.-+  = lookupExactOrOrig rdr_name greName $+    do { mb_gre <- lookupGlobalOccRn_base which_gres rdr_name+       ; case mb_gre of+           Just gre -> return (greName gre)+           Nothing  -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)+                          ; unboundName looking_for rdr_name } }   where+    which_gres   = RelevantGREsFOS WantField+    looking_for  = LF { lf_which = WL_RecField, lf_where =  WL_Global }+      -- This use of Global is right as we are looking up a selector,+      -- which can only be defined at the top level.+     -- When lookup fails, make an unbound name with the right record field     -- namespace, as that's what we expect to be returned     -- from 'lookupRecFieldOcc'. See T14307.@@ -685,25 +681,24 @@ -}  -- | Used in export lists to lookup the children.-lookupSubBndrOcc_helper :: Bool -> DeprecationWarnings-                        -> Name-                        -> RdrName -- ^ thing we are looking up-                        -> LookupChild -- ^ how to look it up (e.g. which-                                       -- 'NameSpace's to look in)+lookupSubBndrOcc_helper :: Bool+                        -> DeprecationWarnings+                        -> ParentGRE     -- ^ parent+                        -> RdrName       -- ^ thing we are looking up                         -> RnM ChildLookupResult-lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name how_lkup-  | isUnboundName parent+lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent_gre rdr_name+  | isUnboundName (parentGRE_name parent_gre)     -- Avoid an error cascade   = return (FoundChild (mkUnboundGRERdr rdr_name))    | otherwise = do   gre_env <- getGlobalRdrEnv-  let original_gres = lookupGRE gre_env (LookupChildren (rdrNameOcc rdr_name) how_lkup)+  let original_gres = lookupGRE gre_env (LookupChildren parent_gre (rdrNameOcc rdr_name))       picked_gres = pick_gres original_gres   -- The remaining GREs are things that we *could* export here.   -- Note that this includes things which have `NoParent`;   -- those are sorted in `checkPatSynParent`.-  traceRn "parent" (ppr parent)+  traceRn "parent" (ppr (parentGRE_name parent_gre))   traceRn "lookupExportChild original_gres:" (ppr original_gres)   traceRn "lookupExportChild picked_gres:" (ppr picked_gres $$ ppr must_have_parent)   case picked_gres of@@ -739,12 +734,12 @@           dup_fields_ok <- xoptM LangExt.DuplicateRecordFields           case original_gres of             []  -> return NameNotFound-            [g] -> return $ IncorrectParent parent g+            [g] -> return $ IncorrectParent parent_gre g                               [p | ParentIs p <- [greParent g]]             gss@(g:gss'@(_:_)) ->               if all isRecFldGRE gss && dup_fields_ok               then return $-                    IncorrectParent parent g+                    IncorrectParent parent_gre g                       [p | x <- gss, ParentIs p <- [greParent x]]               else mkNameClashErr $ g NE.:| gss' @@ -754,22 +749,29 @@           return (FoundChild (NE.head gres))          pick_gres :: [GlobalRdrElt] -> DisambigInfo-        -- For Unqual, find GREs that are in scope qualified or unqualified-        -- For Qual,   find GREs that are in scope with that qualification         pick_gres gres           | isUnqual rdr_name+          -- The child is not qualified: find GREs that are in scope, whether+          -- qualified or unqualified, as per the Haskell 2010 report, 5.2.2:+          --+          --   - In all cases, the parent type constructor T must be in scope.+          --   - A subordinate name is legal if and only if:+          --      (a) it names a constructor or field of T, and+          --      (b) the constructor or field is in scope, regardless of whether+          --          it is in scope under a qualified or unqualified name.           = mconcat (map right_parent gres)           | otherwise+          -- The child is qualified: find GREs that are in scope+          -- with that qualification.           = mconcat (map right_parent (pickGREs rdr_name gres))          right_parent :: GlobalRdrElt -> DisambigInfo         right_parent gre           = case greParent gre of               ParentIs cur_parent-                 | parent == cur_parent -> DisambiguatedOccurrence gre+                 | parentGRE_name parent_gre == cur_parent -> DisambiguatedOccurrence gre                  | otherwise            -> NoOccurrence               NoParent                  -> UniqueOccurrence gre-{-# INLINEABLE lookupSubBndrOcc_helper #-}  -- | This domain specific datatype is used to record why we decided it was -- possible that a GRE could be exported with a parent.@@ -821,44 +823,41 @@       -- | We couldn't find a suitable name       = NameNotFound       -- | The child has an incorrect parent-      | IncorrectParent Name          -- ^ parent-                        GlobalRdrElt  -- ^ child we were looking for-                        [Name]        -- ^ list of possible parents+      | IncorrectParent ParentGRE    -- ^ parent+                        GlobalRdrElt -- ^ child we were looking for+                        [Name]       -- ^ list of possible parents       -- | We resolved to a child       | FoundChild GlobalRdrElt  instance Outputable ChildLookupResult where   ppr NameNotFound = text "NameNotFound"   ppr (FoundChild n) = text "Found:" <+> ppr (greParent n) <+> ppr n-  ppr (IncorrectParent p g ns)+  ppr (IncorrectParent parent g ns)     = text "IncorrectParent"-      <+> hsep [ppr p, ppr $ greName g, ppr ns]+      <+> hsep [ppr (parentGRE_name parent), ppr $ greName g, ppr ns]  lookupSubBndrOcc :: DeprecationWarnings-                 -> Name     -- Parent-                 -> SDoc+                 -> ParentGRE+                 -> Subordinate                  -> RdrName                  -> RnM (Either NotInScopeError Name) -- ^ Find all the things the 'RdrName' maps to, -- and pick the one with the right 'Parent' 'Name'.-lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name =+lookupSubBndrOcc warn_if_deprec the_parent what_subordinate rdr_name =   lookupExactOrOrig rdr_name (Right . greName) $     -- This happens for built-in classes, see mod052 for example-    do { child <- lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name what_lkup+    do { child <- lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name        ; return $ case child of            FoundChild g       -> Right (greName g)-           NameNotFound       -> Left (UnknownSubordinate doc)-           IncorrectParent {} -> Left (UnknownSubordinate doc) }+           NameNotFound       -> Left unknown_sub+           IncorrectParent {} -> Left unknown_sub }        -- See [Mismatched class methods and associated type families]        -- in TcInstDecls.   where-    what_lkup = LookupChild { wantedParent        = the_parent-                            , lookupDataConFirst  = False-                            , prioritiseParent    = True -- See T23664.-                            }-{--Note [Family instance binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    unknown_sub = UnknownSubordinate (parentGRE_name the_parent) what_subordinate++{- Note [Family instance binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   data family F a   data instance F T = X1 | X2@@ -993,10 +992,10 @@ -------------------------------------------------- -} --lookupLocatedOccRn :: GenLocated (EpAnn ann) RdrName+lookupLocatedOccRn :: WhatLooking+                   -> GenLocated (EpAnn ann) RdrName                    -> TcRn (GenLocated (EpAnn ann) Name)-lookupLocatedOccRn = wrapLocMA lookupOccRn+lookupLocatedOccRn what = wrapLocMA (lookupOccRn what)  lookupLocatedOccRnConstr :: GenLocated (EpAnn ann) RdrName                          -> TcRn (GenLocated (EpAnn ann) Name)@@ -1016,25 +1015,20 @@   = do { local_env <- getLocalRdrEnv        ; return (lookupLocalRdrEnv local_env rdr_name) } -lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))+lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevelIndex)) -- Just look in the local environment lookupLocalOccThLvl_maybe name   = do { lcl_env <- getLclEnv        ; return (lookupNameEnv (getLclEnvThBndrs lcl_env) name) } --- lookupOccRn' looks up an occurrence of a RdrName, and uses its argument to+-- | 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+lookupOccRn :: WhatLooking -> RdrName -> RnM Name+lookupOccRn which_suggest rdr_name   = do { mb_gre <- lookupOccRn_maybe rdr_name        ; case mb_gre of            Just gre  -> return $ greName gre-           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+           Nothing   -> reportUnboundName which_suggest rdr_name }  -- | Look up an occurrence of a 'RdrName'. --@@ -1051,7 +1045,9 @@             { mb_ty_gre <- lookup_promoted rdr_name             ; case mb_ty_gre of               Just gre -> return $ greName gre-              Nothing ->  reportUnboundName' WL_Constructor rdr_name} }+              Nothing ->+                reportUnboundName WL_ConLike rdr_name+            } }  {- Note [lookupOccRnConstr] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1078,12 +1074,12 @@ -- 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 = 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+lookupOccRnNone = lookupOccRn WL_None  -- Only used in one place, to rename pattern synonym binders. -- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind@@ -1092,7 +1088,7 @@   = do { mb_name <- lookupLocalOccRn_maybe rdr_name        ; case mb_name of            Just name -> return name-           Nothing   -> unboundName (LF WL_Anything WL_LocalOnly) rdr_name }+           Nothing   -> unboundName (LF WL_TermVariable WL_LocalOnly) rdr_name }  -- lookupTypeOccRn looks up an optionally promoted RdrName. -- Used for looking up type variables.@@ -1124,7 +1120,7 @@ -- Used when looking up a term name (varName or dataName) in a type lookup_demoted :: RdrName -> RnM Name lookup_demoted rdr_name-  | Just demoted_rdr <- demoteRdrName rdr_name+  | Just demoted_rdr <- demoteRdrNameTcCls rdr_name     -- Maybe it's the name of a *data* constructor   = do { data_kinds <- xoptM LangExt.DataKinds        ; star_is_type <- xoptM LangExt.StarIsType@@ -1169,7 +1165,7 @@   = unboundName looking_for rdr_name    where-    looking_for = LF WL_Constructor WL_Anywhere+    looking_for = LF WL_Type WL_Anywhere  {- Note [Demotion of unqualified variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1259,7 +1255,7 @@ report_qualified_term_in_types rdr_name demoted_rdr_name =   do { mName <- lookupGlobalOccRn_maybe (RelevantGREsFOS WantNormal) demoted_rdr_name      ; case mName of-         (Just _) -> termNameInType looking_for rdr_name demoted_rdr_name []+         Just _  -> termNameInType looking_for rdr_name demoted_rdr_name []          Nothing -> unboundTermNameInTypes looking_for rdr_name demoted_rdr_name }   where     looking_for = LF WL_Constructor WL_Global@@ -1322,11 +1318,11 @@ (see the functions promotedRdrName and lookup_promoted).  In particular, we have the following error message-  • Illegal term-level use of the type constructor ‘Int’-      imported from ‘Prelude’ (and originally defined in ‘GHC.Types’)-  • In the first argument of ‘id’, namely ‘Int’+  • Illegal term-level use of the type constructor ‘Int'+      imported from ‘Prelude' (and originally defined in ‘GHC.Types')+  • In the first argument of ‘id'     In the expression: id Int-    In an equation for ‘x’: x = id Int+    In an equation for ‘x': x = id Int  when the user writes the following declaration @@ -1399,28 +1395,6 @@   lookupExactOrOrig_maybe rdr_name id $     lookupGlobalOccRn_base which_gres rdr_name -lookupGlobalOccRn :: RdrName -> RnM Name--- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global--- environment.  Adds an error message if the RdrName is not in scope.--- You usually want to use "lookupOccRn" which also looks in the local--- environment.------ Used by exports_from_avail-lookupGlobalOccRn = lookupGlobalOccRn' (RelevantGREsFOS WantNormal)--lookupGlobalOccRn' :: WhichGREs GREInfo -> RdrName -> RnM Name-lookupGlobalOccRn' which_gres rdr_name =-  lookupExactOrOrig rdr_name greName $ do-    mb_gre <- lookupGlobalOccRn_base which_gres rdr_name-    case mb_gre of-      Just gre -> return (greName gre)-      Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)-                    ; unboundName (LF which_suggest WL_Global) rdr_name }-        where which_suggest = case includeFieldSelectors which_gres of-                WantBoth   -> WL_RecField-                WantField  -> WL_RecField-                WantNormal -> WL_Anything- -- Looks up a RdrName occurrence in the GlobalRdrEnv and with -- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. -- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like@@ -1481,6 +1455,12 @@            do { let (env_fld_gres, env_var_gres) =                       partition isRecFldGRE $                       lookupGRE env (LookupRdrName rdr (RelevantGREsFOS WantBoth))+                -- Make sure to use 'LookupRdrName': if a record update contains+                -- a qualified field name, only look up GREs which are in scope+                -- with that same qualification.+                --+                -- See Wrinkle [Qualified names in record updates]+                -- in Note [Disambiguating record updates] in GHC.Rename.Pat.                -- Handle implicit qualified imports in GHCi. See T10439.               ; ghci_gres <- lookupQualifiedNameGHCi WantBoth rdr@@ -1504,11 +1484,16 @@         -- Add an error if lookup failed.        ; case res of-          gre : gres -> return $ gre NE.:| gres-          [] -> do { (imp_errs, hints) <--                       unknownNameSuggestions emptyLocalRdrEnv WL_RecField rdr-                   ; failWithTc $-                       TcRnNotInScope NotARecordField rdr imp_errs hints } }+          { gre : gres -> return $ gre NE.:| gres+          ; [] ->+    do { show_helpful_errors <- goptM Opt_HelpfulErrors+       ; (imp_errs, hints) <-+           if show_helpful_errors+           then unknownNameSuggestions emptyLocalRdrEnv WL_RecField rdr+           else return ([], [])+       ; err_msg <- unknownNameSuggestionsMessage (TcRnNotInScope NotARecordField rdr) imp_errs hints+       ; failWithTc err_msg+       } } }  -- | Look up a 'RdrName', which might refer to an overloaded record field. --@@ -1553,10 +1538,10 @@                    -> RnM (NE.NonEmpty (HsRecUpdParent GhcRn)) lookupRecUpdFields flds -- See Note [Disambiguating record updates] in GHC.Rename.Pat.-  = do { -- Retrieve the possible GlobalRdrElts that each field could refer to.+  = do { -- (1) Retrieve the possible GlobalRdrElts that each field could refer to.        ; gre_env <- getGlobalRdrEnv        ; fld1_gres NE.:| other_flds_gres <- mapM (lookupFieldGREs gre_env . getFieldUpdLbl) flds-         -- Take an intersection: we are only interested in constructors+         -- (2) Take an intersection: we are only interested in constructors          -- which have all of the fields.        ; let possible_GREs = intersect_by_cons fld1_gres other_flds_gres @@ -1567,15 +1552,16 @@         ; case possible_GREs of -          -- There is at least one parent: we can proceed.+          -- (3) (a) There is at least one parent: we can proceed.           -- The typechecker might be able to finish disambiguating.           -- See Note [Type-directed record disambiguation] in GHC.Rename.Pat.        { p1:ps -> return (p1 NE.:| ps) -          -- There are no possible parents for the record update: compute-          -- a minimum set of fields which does not belong to any data constructor,-          -- to report an informative error to the user.-       ; _ ->+          -- (3) (b) There are no possible parents for the record update:+          -- compute a minimal set of fields which does not belong to any+          -- data constructor, to report an informative error to the user.+       ; _ -> do+          hsc_env <- getTopEnv           let             -- The constructors which have the first field.             fld1_cons :: UniqSet ConLikeName@@ -1585,9 +1571,9 @@             -- The field labels of the constructors which have the first field.             fld1_cons_fields :: UniqFM ConLikeName [FieldLabel]             fld1_cons_fields-              = fmap (lkp_con_fields gre_env)+              = fmap (lkp_con_fields hsc_env gre_env)               $ getUniqSet fld1_cons-          in failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } }+          failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } }    where     intersect_by_cons :: NE.NonEmpty FieldGlobalRdrElt@@ -1606,13 +1592,22 @@       , not $ isEmptyUniqSet both_cons       ] -    lkp_con_fields :: GlobalRdrEnv -> ConLikeName -> [FieldLabel]-    lkp_con_fields gre_env con =+    -- Look up all in-scope fields of a 'ConLike'.+    lkp_con_fields :: HscEnv -> GlobalRdrEnv -> ConLikeName -> [FieldLabel]+    lkp_con_fields hsc_env gre_env con =       [ fl-      | let nm = conLikeName_Name con-      , gre      <- maybeToList $ lookupGRE_Name gre_env nm-      , con_info <- maybeToList $ recFieldConLike_maybe gre-      , fl       <- conInfoFields con_info ]+      | let con_nm = conLikeName_Name con+            gre_info =+              (greInfo <$> lookupGRE_Name gre_env con_nm)+                `orElse`+              lookupGREInfo hsc_env con_nm+              -- See Wrinkle [Out of scope constructors]+              -- in Note [Disambiguating record updates] in GHC.Rename.Pat.+      , IAmConLike con_info <- [ gre_info ]+      , fl <- conInfoFields con_info+      , isJust $ lookupGRE_FieldLabel gre_env fl+             -- Ensure the fields are in scope.+      ]  {-********************************************************************** *                                                                      *@@ -1636,8 +1631,9 @@ -- aren't really relevant to the problem. -- -- NB: this error message should only be triggered when all the field names--- are in scope (i.e. each individual field name does belong to some--- constructor in scope).+-- are in scope. It's OK if the constructors themselves are not in scope+-- (see Wrinkle [Out of scope constructors] in Note [Disambiguating record updates]+-- in GHC.Rename.Pat). badFieldsUpd   :: (OutputableBndrId p)   => [LHsRecUpdField (GhcPass p) q]@@ -1670,7 +1666,7 @@             in             -- Fields that don't change the membership status of the set             -- are redundant and can be dropped.-            map (fst . head) $ groupBy ((==) `on` snd) growingSets+            map (fst . NE.head) $ NE.groupBy ((==) `on` snd) growingSets      aMember = assert (not (null members) ) fst (head members)     (members, nonMembers) = partition (or . snd) membership@@ -1784,18 +1780,18 @@             -- until we know which is meant             (gre:others) -> return (MultipleNames (gre NE.:| others)) } -lookupGreAvailRn :: RdrName -> RnM (Maybe GlobalRdrElt)+lookupGreAvailRn :: WhatLooking -> RdrName -> RnM (Maybe GlobalRdrElt) -- Used in export lists -- If not found or ambiguous, add error message, and fake with UnboundName -- Uses addUsedRdrName to record use and deprecations-lookupGreAvailRn rdr_name+lookupGreAvailRn what_looking rdr_name   = do       mb_gre <- lookupGreRn_helper (RelevantGREsFOS WantNormal) rdr_name ExportDeprecationWarnings       case mb_gre of         GreNotFound ->           do             traceRn "lookupGreAvailRn" (ppr rdr_name)-            _ <- unboundName (LF WL_Anything WL_Global) rdr_name+            _ <- unboundName (LF what_looking WL_Global) rdr_name             return Nothing         MultipleNames gres ->           do@@ -1896,7 +1892,7 @@ `Data.List` as if the user had written `import qualified Data.List`.  If we fail we just return Nothing, rather than bleating-about "attempting to use module ‘D’ (./D.hs) which is not loaded"+about "attempting to use module 'D' (./D.hs) which is not loaded" which is what loadSrcInterface does.  It is enabled by default and disabled by the flag@@ -1999,7 +1995,13 @@           , gre_info = info }         where           info = lookupGREInfo hsc_env nm-          spec = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, is_pkg_qual = NoPkgQual, is_qual = True, is_isboot = NotBoot, is_dloc = noSrcSpan }+          spec = ImpDeclSpec { is_mod = mod+                             , is_as = moduleName mod+                             , is_pkg_qual = NoPkgQual+                             , is_qual = True+                             , is_isboot = NotBoot+                             , is_dloc = noSrcSpan+                             , is_level = NormalLevel }           is = ImpSpec { is_decl = spec, is_item = ImpAll }  -- | Look up the 'GREInfo' associated with the given 'Name'@@ -2013,6 +2015,8 @@   -- and looks up the TyThing in the type environment.   --   -- See Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo.+  -- Note: This function is very similar to 'tcIfaceGlobal', it would be better to+  -- use that if possible.   = case nameModule_maybe nm of       Nothing  -> UnboundGRE       Just mod ->@@ -2070,6 +2074,28 @@       f :: C a => a -> a   -- No, not ok       class C a where         f :: a -> a++Note [Signatures in instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   class C a where+     op :: a -> a+     nop :: a -> a++   instance C ty where+     bop :: [a] -> [a]+     bop x = x++     nop :: [a] -> [a]++When renameing the `bop` binding we'll give it an UnboundName (still with+OccName "bop") because `bop` is not a method of C.  Then++* when doing lookupSigOcc on `bop :: blah` we want to find `bop`, even though it+  is an UnboundName (failing to do this causes #16610, and #25437)++* When doing lookupSigOcc on `nop :: blah` we want to complain that there+  is no accompanying binding, even though `nop` is a class method -}  data HsSigCtxt@@ -2077,8 +2103,8 @@                              -- See Note [Signatures for top level things]   | LocalBindCtxt NameSet    -- In a local binding, binding these names   | ClsDeclCtxt   Name       -- Class decl for this class-  | InstDeclCtxt  NameSet    -- Instance decl whose user-written method-                             -- bindings are for these methods+  | InstDeclCtxt  (OccEnv Name)  -- Instance decl whose user-written method+                                 -- bindings are described by this OccEnv   | HsBootCtxt NameSet       -- Top level of a hs-boot file, binding these names   | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types                              -- in the group@@ -2093,18 +2119,13 @@  lookupSigOccRn :: HsSigCtxt                -> Sig GhcPs-               -> LocatedA RdrName -> RnM (LocatedA Name)-lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)--lookupSigOccRnN :: HsSigCtxt-               -> Sig GhcPs-               -> LocatedN RdrName -> RnM (LocatedN Name)-lookupSigOccRnN ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)+               -> GenLocated (EpAnn ann) RdrName+               -> RnM (GenLocated (EpAnn ann) Name)+lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (SigLikeSig sig)  -- | Lookup a name in relation to the names in a 'HsSigCtxt' lookupSigCtxtOccRn :: HsSigCtxt-                   -> SDoc         -- ^ description of thing we're looking up,-                                   -- like "type family"+                   -> SigLike -- ^ what are we looking for, e.g. a type family                    -> GenLocated (EpAnn ann) RdrName                    -> RnM (GenLocated (EpAnn ann) Name) lookupSigCtxtOccRn ctxt what@@ -2117,12 +2138,12 @@                     vcat (text "lookupSigCtxtOccRn" <+> ppr name : map (either (pprScopeError rdr_name) ppr) rest)                 ; return name }            Left err NE.:| _ ->-             do { addErr (mkTcRnNotInScope rdr_name err)+             do { addErr $ TcRnNotInScope err rdr_name                 ; return (mkUnboundNameRdr rdr_name) }        }  lookupBindGroupOcc :: HsSigCtxt-                   -> SDoc+                   -> SigLike -- ^ what kind of thing are we looking for?                    -> RdrName -- ^ what to look up                    -> Bool -- ^ if the 'RdrName' we are looking up is in                            -- a value 'NameSpace', should we also look up@@ -2153,34 +2174,38 @@       RoleAnnotCtxt ns -> lookup_top (elem_name_set_with_namespace ns)       LocalBindCtxt ns -> lookup_group ns       ClsDeclCtxt  cls -> lookup_cls_op cls-      InstDeclCtxt ns  -> if uniqSetAny isUnboundName ns -- #16610-                          then return $ NE.singleton $ Right $ mkUnboundNameRdr rdr_name-                          else lookup_top (elem_name_set_with_namespace ns)+      InstDeclCtxt occ_env-> lookup_inst occ_env   where     elem_name_set_with_namespace ns n = check_namespace n && (n `elemNameSet` ns)      check_namespace = coveredByNamespaceSpecifier ns_spec . nameNameSpace      namespace = occNameSpace occ-    occ = rdrNameOcc rdr_name-    relevant_gres =-      RelevantGREs-        { includeFieldSelectors = WantBoth-        , lookupVariablesForFields = True-        , lookupTyConsAsWell = also_try_tycon_ns }-    ok_gre = greIsRelevant relevant_gres namespace+    occ       = rdrNameOcc rdr_name+    ok_gre    = greIsRelevant relevant_gres namespace+    relevant_gres = RelevantGREs { includeFieldSelectors    = WantBoth+                                 , lookupVariablesForFields = True+                                 , lookupTyConsAsWell = also_try_tycon_ns }      finish err gre       | ok_gre gre-      = NE.singleton (Right $ greName gre)+      = NE.singleton (Right (greName gre))       | otherwise       = NE.singleton (Left err) +    succeed_with n = return $ NE.singleton $ Right n+     lookup_cls_op cls-      = NE.singleton <$> lookupSubBndrOcc AllDeprecationWarnings cls doc rdr_name-      where-        doc = text "method of class" <+> quotes (ppr cls)+      = NE.singleton <$>+          lookupSubBndrOcc AllDeprecationWarnings+            (ParentGRE cls (IAmTyCon ClassFlavour))+            MethodOfClass rdr_name +    lookup_inst occ_env  -- See Note [Signatures in instance decls]+      = case lookupOccEnv occ_env occ of+           Nothing -> bale_out_with []+           Just n  -> succeed_with n+     lookup_top keep_me       = do { env <- getGlobalRdrEnv            ; let occ = rdrNameOcc rdr_name@@ -2203,7 +2228,7 @@            ; let candidates_msg = candidates $ localRdrEnvElts env            ; case mname of                Just n-                 | n `elemNameSet` bound_names -> return $ NE.singleton $ Right n+                 | n `elemNameSet` bound_names -> succeed_with n                  | otherwise                   -> bale_out_with local_msg                Nothing                         -> bale_out_with candidates_msg } @@ -2226,7 +2251,7 @@   ----------------lookupLocalTcNames :: HsSigCtxt -> SDoc -> NamespaceSpecifier -> RdrName -> RnM [(RdrName, Name)]+lookupLocalTcNames :: HsSigCtxt -> SigLike -> NamespaceSpecifier -> RdrName -> RnM [(RdrName, Name)] -- GHC extension: look up both the tycon and data con or variable. -- Used for top-level fixity signatures and deprecations. -- Complain if neither is in scope.@@ -2243,13 +2268,13 @@   where     -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233     guard_builtin_syntax this_mod rdr (Right name)-      | Just _ <- isBuiltInOcc_maybe (occName rdr)+      | isBuiltInOcc (occName rdr)       , this_mod /= nameModule name       = Left $ TcRnIllegalBuiltinSyntax what rdr       | otherwise       = Right (rdr, name)     guard_builtin_syntax _ _ (Left err)-      = Left $ mkTcRnNotInScope rdr err+      = Left $ TcRnNotInScope err rdr  dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName@@ -2350,14 +2375,14 @@                  -> RnM (HsExpr GhcRn, FreeVars)  -- ^ Possibly a non-standard name lookupSyntaxExpr std_name   = do { (name, fvs) <- lookupSyntaxName std_name-       ; return (nl_HsVar name, fvs) }+       ; return (genHsVar name, fvs) }  lookupSyntax :: Name                             -- The standard name              -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard                                                  -- name lookupSyntax std_name-  = do { (expr, fvs) <- lookupSyntaxExpr std_name-       ; return (mkSyntaxExpr expr, fvs) }+  = do { (name, fvs) <- lookupSyntaxName std_name+       ; return (mkRnSyntaxExpr name, fvs) }  lookupSyntaxNames :: [Name]                         -- Standard names      -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames@@ -2365,11 +2390,11 @@ lookupSyntaxNames std_names   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if not rebindable_on then-             return (map (HsVar noExtField . noLocA) std_names, emptyFVs)+             return (map (mkHsVar . noLocA) std_names, emptyFVs)         else           do { usr_names <-                  mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names-             ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } }+             ; return (map (mkHsVar . noLocA) usr_names, mkFVs usr_names) } }   {-@@ -2387,15 +2412,9 @@  -- Lookup operations for a qualified do. If the context is not a qualified -- do, then use lookupSyntaxExpr. See Note [QualifiedDo].-lookupQualifiedDoExpr :: HsStmtContext fn -> Name -> RnM (HsExpr GhcRn, FreeVars)-lookupQualifiedDoExpr ctxt std_name-  = first nl_HsVar <$> lookupQualifiedDoName ctxt std_name---- Like lookupQualifiedDoExpr but for producing SyntaxExpr.--- See Note [QualifiedDo]. lookupQualifiedDo :: HsStmtContext fn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) lookupQualifiedDo ctxt std_name-  = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name+  = first mkRnSyntaxExpr <$> lookupQualifiedDoName ctxt std_name  lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) lookupNameWithQualifier std_name modName@@ -2406,7 +2425,7 @@ lookupQualifiedDoName :: HsStmtContext fn -> Name -> RnM (Name, FreeVars) lookupQualifiedDoName ctxt std_name   = case qualifiedDoModuleName_maybe ctxt of-      Nothing -> lookupSyntaxName std_name+      Nothing      -> lookupSyntaxName std_name       Just modName -> lookupNameWithQualifier std_name modName  --------------------------------------------------------------------------------@@ -2420,9 +2439,9 @@                      => HscEnv                      -> GlobalRdrEnv                      -> CompleteMatches -- ^ in-scope COMPLETE pragmas-                     -> Name -- ^ the 'Name' of the 'ConLike'+                     -> WithUserRdr Name -- ^ the 'Name' of the 'ConLike'                      -> Bool-irrefutableConLikeRn hsc_env rdr_env comps con_nm+irrefutableConLikeRn hsc_env rdr_env comps (WithUserRdr _ con_nm)   | Just gre <- lookupGRE_Name rdr_env con_nm   = go $ greInfo gre   | otherwise
compiler/GHC/Rename/Expr.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE CPP                 #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-}@@ -10,7 +11,6 @@ {-# LANGUAGE ViewPatterns        #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}  {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -29,33 +29,28 @@         AnnoBody, UnexpectedStatement(..)    ) where -import GHC.Prelude-import GHC.Data.FastString--import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS-                        , rnMatchGroup, rnGRHS, makeMiniFixityEnv)+import GHC.Prelude hiding (head, init, last, scanl, tail) import GHC.Hs+ import GHC.Tc.Errors.Types-import GHC.Tc.Utils.Env ( isBrackStage )+import GHC.Tc.Utils.Env ( isBrackLevel ) import GHC.Tc.Utils.Monad-import GHC.Unit.Module ( getModule, isInteractiveModule )++import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS+                       , rnMatchGroup, rnGRHS, makeMiniFixityEnv) import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames-                        , bindLocalNames-                        , mapMaybeFvRn, mapFvRn-                        , warnUnusedLocalBinds, typeAppErr-                        , checkUnusedRecordWildcard-                        , wrapGenSpan, genHsIntegralLit, genHsTyLit-                        , genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps'-                        , genAppType )+import GHC.Rename.Utils import GHC.Rename.Unbound ( reportUnboundName )-import GHC.Rename.Splice  ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName )+import GHC.Rename.Splice  ( rnTypedBracket, rnUntypedBracket, rnTypedSplice+                          , rnUntypedSpliceExpr, checkThLocalNameWithLift, checkThLocalNameNoLift ) import GHC.Rename.HsType import GHC.Rename.Pat+ import GHC.Driver.DynFlags import GHC.Builtin.Names import GHC.Builtin.Types ( nilDataConName )+import GHC.Unit.Module ( getModule, isInteractiveModule )  import GHC.Types.Basic (TypeOrKind (TypeLevel)) import GHC.Types.FieldLabel@@ -67,25 +62,30 @@ import GHC.Types.Unique.Set import GHC.Types.SourceText import GHC.Types.SrcLoc+ import GHC.Utils.Misc-import GHC.Data.List.SetOps ( removeDupsOn )-import GHC.Data.Maybe+import qualified GHC.Data.List.NonEmpty as NE import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString+import GHC.Data.List.SetOps ( removeDupsOn )+import GHC.Data.Maybe+ import qualified GHC.LanguageExtensions as LangExt  import Language.Haskell.Syntax.Basic (FieldLabelString(..))  import Control.Monad-import Data.List (unzip4, minimumBy)-import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )+import qualified Data.Foldable as Partial (maximum)+import Data.List (unzip4)+import Data.List.NonEmpty ( NonEmpty(..), head, init, last, nonEmpty, scanl, tail ) import Control.Arrow (first) import Data.Ord import Data.Array-import qualified Data.List.NonEmpty as NE import GHC.Driver.Env (HscEnv)+import Data.Foldable (toList)  {- Note [Handling overloaded and rebindable constructs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -306,27 +306,19 @@  rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)--- Separated from rnExpr because it's also used--- when renaming infix expressions-finishHsVar (L l name)- = do { this_mod <- getModule-      ; when (nameIsLocalOrFrom this_mod name) $-        checkThLocalName name-      ; return (HsVar noExtField (L (l2l l) name), unitFV name) }--rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)-rnUnboundVar v = do+rnUnboundVar :: SrcSpanAnnN -> RdrName -> RnM (HsExpr GhcRn, FreeVars)+rnUnboundVar l v = do   deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables   -- See Note [Reporting unbound names] for difference between qualified and unqualified names.-  unless (isUnqual v || deferOutofScopeVariables) (reportUnboundName v >> return ())-  return (HsUnboundVar noExtField v, emptyFVs)+  unless (isUnqual v || deferOutofScopeVariables) $+    void $ reportUnboundName WL_Term v+  return (HsHole (HoleVar (L l v)), emptyFVs)  rnExpr (HsVar _ (L l v))   = do { dflags <- getDynFlags        ; mb_gre <- lookupExprOccRn v        ; case mb_gre of {-           Nothing -> rnUnboundVar v ;+           Nothing -> rnUnboundVar l v ;            Just gre ->     do { let nm   = greName gre              info = greInfo gre@@ -336,9 +328,7 @@             -- matching GRE and add a name clash error             -- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn).             -> do { let sel_name = flSelector $ recFieldLabel fld_info-                  ; this_mod <- getModule-                  ; when (nameIsLocalOrFrom this_mod sel_name) $-                      checkThLocalName sel_name+                  ; checkThLocalNameNoLift (L (l2l l) (WithUserRdr v sel_name))                   ; return (XExpr (HsRecSelRn (FieldOcc v  (L l sel_name))), unitFV sel_name)                   }             | nm == nilDataConName@@ -349,14 +339,16 @@             -> rnExpr (ExplicitList noAnn [])              | otherwise-            -> finishHsVar (L (l2l l) nm)+            -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v nm))+                  ; return (res_expr, unitFV nm) }         }}} + rnExpr (HsIPVar x v)   = return (HsIPVar x v, emptyFVs) -rnExpr (HsUnboundVar _ v)-  = return (HsUnboundVar noExtField v, emptyFVs)+rnExpr (HsHole h)+  = return (HsHole h, emptyFVs)  -- HsOverLabel: see Note [Handling overloaded and rebindable constructs] rnExpr (HsOverLabel src v)@@ -383,7 +375,7 @@  rnExpr (HsLit x lit)   = do { rnLit lit-       ; return (HsLit x(convertLit lit), emptyFVs) }+       ; return (HsLit x (convertLit lit), emptyFVs) }  rnExpr (HsOverLit x lit)   = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]@@ -416,7 +408,7 @@         -- more, so I've removed the test.  Adding HsPars in GHC.Tc.Deriv.Generate         -- should prevent bad things happening.         ; fixity <- case op' of-              L _ (HsVar _ (L _ n))      -> lookupFixityRn n+              L _ (HsVar _ (L _ (WithUserRdr _ n))) -> lookupFixityRn n               L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f               _ -> return (Fixity minPrecedence InfixL)                    -- c.f. lookupFixity for unbound@@ -447,7 +439,7 @@  rnExpr (HsProjection _ fs)   = do { (getField, fv_getField) <- lookupSyntaxName getFieldName-       ; circ <- lookupOccRn compose_RDR+       ; circ <- lookupOccRn WL_TermVariable compose_RDR        ; let fs' = NE.map rnDotFieldOcc fs        ; return ( mkExpandedExpr                     (HsProjection noExtField fs')@@ -541,15 +533,17 @@  rnExpr (RecordCon { rcon_con = con_rdr                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })-  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_rdr-       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds+  = do { L con_loc con_name <- lookupLocatedOccRnConstr con_rdr+       ; let qcon = WithUserRdr (unLoc con_rdr) con_name+       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon qcon) mk_hs_var rec_binds        ; (flds', fvss) <- mapAndUnzipM rn_field flds        ; let rec_binds' = HsRecFields { rec_ext = noExtField, rec_flds = flds', rec_dotdot = dd }        ; return (RecordCon { rcon_ext = noExtField-                           , rcon_con = con_lname, rcon_flds = rec_binds' }+                           , rcon_con = L con_loc qcon+                           , rcon_flds = rec_binds' }                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }   where-    mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n)+    mk_hs_var l n = mkHsVarWithUserRdr (unLoc con_rdr) (L (noAnnSrcSpan l) n)     rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld)                             ; return (L l (fld { hfbRHS = arg' }), fvs) } @@ -634,7 +628,7 @@  rnExpr (HsFunArr _ mult arg res)   = do { (arg', fvs1) <- rnLExpr arg-       ; (mult', fvs2) <- rnHsArrowWith rnLExpr mult+       ; (mult', fvs2) <- rnHsMultAnnWith rnLExpr mult        ; (res', fvs3) <- rnLExpr res        ; checkTypeSyntaxExtension FunctionArrowSyntax        ; return (HsFunArr noExtField mult' arg' res', plusFVs [fvs1, fvs2, fvs3]) }@@ -662,9 +656,9 @@     unlessXOptM LangExt.StaticPointers $       addErr $ TcRnIllegalStaticExpression e     (expr',fvExpr) <- rnLExpr expr-    stage <- getStage-    case stage of-      Splice _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e+    level <- getThLevel+    case level of+      Splice _ _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e       _        -> return ()     mod <- getModule     let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr@@ -861,8 +855,8 @@ Note [Reporting unbound names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Faced with an out-of-scope `RdrName` there are two courses of action-A. Report an error immediately (and return a HsUnboundVar). This will halt GHC after the renamer is complete-B. Return a HsUnboundVar without reporting an error.  That will allow the typechecker to run, which in turn+A. Report an error immediately (and return a `HsHole (HoleVar ...)`). This will halt GHC after the renamer is complete+B. Return a `HsHole (HoleVar ...)` without reporting an error.  That will allow the typechecker to run, which in turn    can give a better error message, notably giving the type of the variable via the "typed holes" mechanism.  When `-fdefer-out-of-scope-variables` is on we follow plan B.@@ -893,7 +887,7 @@ rnDotFieldOcc (DotFieldOcc x label) = DotFieldOcc x label  rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn-rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map (fmap rnDotFieldOcc) fls)+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (fmap (fmap rnDotFieldOcc) fls)  {- ************************************************************************@@ -1036,7 +1030,8 @@ ------------------------------------------------- -- gaw 2004 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars-methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)+methodNamesGRHSs (GRHSs _ grhss _)+  = foldl' (flip plusFV) emptyFVs (NE.map methodNamesGRHS grhss)  ------------------------------------------------- @@ -1157,7 +1152,7 @@                         | otherwise = False        -- don't apply the transformation inside TH brackets, because        -- GHC.HsToCore.Quote does not handle ApplicativeDo.-       ; in_th_bracket <- isBrackStage <$> getStage+       ; in_th_bracket <- isBrackLevel <$> getThLevel        ; if ado_is_on && is_do_expr && not in_th_bracket             then do { traceRn "ppsfa" (ppr stmts)                     ; rearrangeForApplicativeDo ctxt stmts }@@ -1378,34 +1373,40 @@  rnParallelStmts :: forall thing. HsStmtContextRn                 -> SyntaxExpr GhcRn-                -> [ParStmtBlock GhcPs GhcPs]+                -> NonEmpty (ParStmtBlock GhcPs GhcPs)                 -> ([Name] -> RnM (thing, FreeVars))-                -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)+                -> RnM ((NonEmpty (ParStmtBlock GhcRn GhcRn), thing), FreeVars) -- Note [Renaming parallel Stmts] rnParallelStmts ctxt return_op segs thing_inside   = do { orig_lcl_env <- getLocalRdrEnv-       ; rn_segs orig_lcl_env [] segs }+       ; rn_segs (:|) orig_lcl_env [] segs }   where-    rn_segs :: LocalRdrEnv-            -> [Name] -> [ParStmtBlock GhcPs GhcPs]-            -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)-    rn_segs _ bndrs_so_far []-      = do { let (bndrs', dups) = removeDupsOn nameOccName bndrs_so_far-           ; mapM_ dupErr dups-           ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')-           ; return (([], thing), fvs) }--    rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)+    -- The `cons` argument is how we cons the first `ParStmtBlock` onto the rest.+    -- It is called with `cons = (:)` or `cons = (:|)`.+    -- Thus, the return type `parStmtBlocks` is `[ParStmtBlock _ _]` or+    -- `NonEmpty (ParStmtBlock _ _)`, in turn.+    rn_segs :: (ParStmtBlock GhcRn GhcRn -> [ParStmtBlock GhcRn GhcRn] -> parStmtBlocks)+            -> LocalRdrEnv+            -> [Name] -> NonEmpty (ParStmtBlock GhcPs GhcPs)+            -> RnM ((parStmtBlocks, thing), FreeVars)+    rn_segs cons env bndrs_so_far (ParStmtBlock x stmts _ _ :| segs)       = do { ((stmts', (used_bndrs, segs', thing)), fvs)                     <- rnStmts ctxt rnExpr stmts $ \ bndrs ->                        setLocalRdrEnv env       $ do-                       { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs+                       { ((segs', thing), fvs) <- rn_segs1 env (bndrs ++ bndrs_so_far) segs                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs                        ; return ((used_bndrs, segs', thing), fvs) }             ; let seg' = ParStmtBlock x stmts' used_bndrs return_op-           ; return ((seg':segs', thing), fvs) }+           ; return ((cons seg' segs', thing), fvs) } +    rn_segs1 _ bndrs [] = do+      { let (bndrs', dups) = removeDupsOn nameOccName bndrs+      ; mapM_ dupErr dups+      ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')+      ; return (([], thing), fvs) }+    rn_segs1 env bndrs (x:xs) = rn_segs (:) env bndrs (x:|xs)+     dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs)  lookupQualifiedDoStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)@@ -1414,7 +1415,7 @@   = case qualifiedDoModuleName_maybe ctxt of       Nothing -> lookupStmtName ctxt n       Just modName ->-        first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName+        first mkRnSyntaxExpr <$> lookupNameWithQualifier n modName  lookupStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Like lookupSyntax, but respects contexts@@ -1429,13 +1430,13 @@   | rebindableContext ctxt   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if rebindable_on-         then do { fm <- lookupOccRn (nameRdrName name)-                 ; return (HsVar noExtField (noLocA fm), unitFV fm) }+         then do { fm <- lookupOccRn WL_TermVariable (nameRdrName name)+                 ; return (mkHsVar (noLocA fm), unitFV fm) }          else not_rebindable }   | otherwise   = not_rebindable   where-    not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs)+    not_rebindable = return (mkHsVar (noLocA name), emptyFVs)  -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable@@ -1806,7 +1807,7 @@  glomSegments :: HsStmtContextRn              -> [Segment (LStmt GhcRn body)]-             -> [Segment [LStmt GhcRn body]]+             -> [Segment (NonEmpty (LStmt GhcRn body))]                                   -- Each segment has a non-empty list of Stmts -- See Note [Glomming segments] @@ -1822,7 +1823,7 @@     seg_defs  = plusFVs ds `plusFV` defs     seg_uses  = plusFVs us `plusFV` uses     seg_fwds  = plusFVs fs `plusFV` fwds-    seg_stmts = stmt : concat ss+    seg_stmts = stmt :| concatMap toList ss      grab :: NameSet             -- The client          -> [Segment a]@@ -1838,24 +1839,23 @@ ---------------------------------------------------- segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn))                                   -- A RecStmt with the SyntaxOps filled in-            -> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]+            -> [Segment (NonEmpty (LStmt GhcRn (LocatedA (body GhcRn))))]                                   -- Each Segment has a non-empty list of Stmts             -> FreeVars           -- Free vars used 'later'             -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)  segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later-  = assert (not (null ss))-    (new_stmt : later_stmts, later_uses `plusFV` uses)+  = (new_stmt : later_stmts, later_uses `plusFV` uses)   where     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later     new_stmt | non_rec   = head ss              | otherwise = L (getLoc (head ss)) rec_stmt-    rec_stmt = empty_rec_stmt { recS_stmts     = noLocA ss+    rec_stmt = empty_rec_stmt { recS_stmts     = noLocA (toList ss)                               , recS_later_ids = nameSetElemsStable used_later                               , recS_rec_ids   = nameSetElemsStable fwds }           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]-    non_rec    = isSingleton ss && isEmptyNameSet fwds+    non_rec    = NE.isSingleton ss && isEmptyNameSet fwds     used_later = defs `intersectNameSet` later_uses                                 -- The ones needed after the RecStmt @@ -2031,10 +2031,9 @@ rearrangeForApplicativeDo ctxt [(one,_)] = do   (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName   (pure_name, _)   <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName-  let pure_expr = nl_HsVar pure_name   let monad_names = MonadNames { return_name = return_name                                , pure_name   = pure_name }-  return $ case needJoin monad_names [one] (Just pure_expr) of+  return $ case needJoin monad_names [one] (Just pure_name) of     (False, one') -> (one', emptyNameSet)     (True, _) -> ([one], emptyNameSet) rearrangeForApplicativeDo ctxt stmts0 = do@@ -2115,9 +2114,10 @@          case segments [ stmt_arr ! i | i <- [lo..hi] ] of            [] -> panic "mkStmtTree"            [_one] -> split lo hi-           segs -> (StmtTreeApplicative trees, maximum costs)+           segs -> (StmtTreeApplicative trees, Partial.maximum costs)              where                bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs+               -- We know `costs` must be non-empty, as `length segs >= 2` here.                (trees,costs) = unzip (map (uncurry split) (tail bounds))      -- find the best place to split the segment [lo..hi]@@ -2136,21 +2136,21 @@          -- in the case that these two have the same cost do we need          -- to do the exhaustive search.          ---         ((before,c1),(after,c2))-           | hi - lo == 1-           = ((StmtTreeOne (stmt_arr ! lo), 1),-              (StmtTreeOne (stmt_arr ! hi), 1))-           | left_cost < right_cost-           = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))-           | left_cost > right_cost-           = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))-           | otherwise = minimumBy (comparing cost) alternatives+         ((before,c1),(after,c2)) = case nonEmpty [lo .. hi-1] of+             Nothing ->+               ( (StmtTreeOne (stmt_arr ! lo), 1),+                 (StmtTreeOne (stmt_arr ! hi), 1) )+             Just ks+               | left_cost < right_cost+               -> ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))+               | left_cost > right_cost+               -> ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))+               | otherwise -> minimumBy (comparing cost)+                 [ (arr ! (lo,k), arr ! (k+1,hi)) | k <- ks ]            where              (left, left_cost) = arr ! (lo,hi-1)              (right, right_cost) = arr ! (lo+1,hi)              cost ((_,c1),(_,c2)) = c1 + c2-             alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))-                            | k <- [lo .. hi-1] ]   -- | Turn the ExprStmtTree back into a sequence of statements, using@@ -2196,8 +2196,8 @@        }] False tail' stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_))                 tail _tail_fvs = do-  (pure_expr, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName-  return $ case needJoin monad_names tail (Just pure_expr) of+  (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName+  return $ case needJoin monad_names tail (Just pure_name) of     (False, tail') -> (let_stmt : tail', emptyNameSet)     (True, _) -> (let_stmt : tail, emptyNameSet) @@ -2250,13 +2250,13 @@          tup = mkBigLHsVarTup pvars noExtField      (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset      (mb_ret, fvs1) <--        if | L _ (XStmtLR ApplicativeStmt{}) <- last stmts' ->+        if | Just (L _ (XStmtLR ApplicativeStmt{})) <- lastMaybe stmts' ->              return (unLoc tup, emptyNameSet)            | otherwise -> do              -- Need 'pureAName' and not 'returnMName' here, so that it requires              -- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed).-             (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName-             let expr = HsApp noExtField (noLocA ret) tup+             (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName+             let expr = HsApp noExtField (noLocA (genHsVar pure_name)) tup              return (expr, emptyFVs)      return ( ApplicativeArgMany               { xarg_app_arg_many = noExtField@@ -2522,7 +2522,7 @@          -> [ExprLStmt GhcRn]             -- If this is @Just pure@, replace return by pure             -- If this is @Nothing@, strip the return/pure-         -> Maybe (HsExpr GhcRn)+         -> Maybe Name          -> (Bool, [ExprLStmt GhcRn]) needJoin _monad_names [] _mb_pure = (False, [])  -- we're in an ApplicativeArg needJoin monad_names  [L loc (LastStmt _ e _ t)] mb_pure@@ -2543,30 +2543,30 @@             -> LHsExpr GhcRn             -- If this is @Just pure@, replace return by pure             -- If this is @Nothing@, strip the return/pure-            -> Maybe (HsExpr GhcRn)+            -> Maybe Name             -> Maybe (LHsExpr GhcRn, Maybe Bool) isReturnApp monad_names (L _ (HsPar _ expr)) mb_pure =   isReturnApp monad_names expr mb_pure isReturnApp monad_names (L loc e) mb_pure = case e of   OpApp x l op r-    | Just pure_expr <- mb_pure, is_return l, is_dollar op ->-        Just (L loc (OpApp x (to_pure l pure_expr) op r), Nothing)+    | Just pure_name <- mb_pure, is_return l, is_dollar op ->+        Just (L loc (OpApp x (to_pure l pure_name) op r), Nothing)     | is_return l, is_dollar op -> Just (r, Just True)   HsApp x f arg-    | Just pure_expr <- mb_pure, is_return f ->-        Just (L loc (HsApp x (to_pure f pure_expr) arg), Nothing)+    | Just pure_name <- mb_pure, is_return f ->+        Just (L loc (HsApp x (to_pure f pure_name) arg), Nothing)     | is_return f -> Just (arg, Just False)   _otherwise -> Nothing  where   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+  is_var f (L _ (HsVar _ (L _ (WithUserRdr _q r)))) = f r        -- TODO: I don't know how to get this right for rebindable syntax   is_var _ _ = False    is_return = is_var (\n -> n == return_name monad_names                          || n == pure_name monad_names)-  to_pure (L loc _) pure_expr = L loc pure_expr+  to_pure (L loc _) pure_name = L loc (genHsVar pure_name)   is_dollar = is_var (`hasKey` dollarIdKey)  {-@@ -2792,13 +2792,13 @@      reallyGetMonadFailOp rebindableSyntax overloadedStrings       | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do-        (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName+        (failName, failFvs) <- lookupQualifiedDoName ctxt failMName         (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName         let arg_lit = mkVarOccFS (fsLit "arg")         arg_name <- newSysName arg_lit         let arg_syn_expr = nlHsVar arg_name             body :: LHsExpr GhcRn =-              nlHsApp (noLocA failExpr)+              nlHsApp (noLocA (genHsVar failName))                       (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)         let failAfterFromStringExpr :: HsExpr GhcRn =               unLoc $ mkHsLam (noLocA [noLocA $ VarPat noExtField $ noLocA arg_name]) body@@ -2844,18 +2844,18 @@ -- mkGetField arg field calculates a get_field @field arg expression. -- e.g. z.x = mkGetField z x = get_field @x z mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn-mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)+mkGetField get_field arg field = unLoc (head $ mkGet get_field (arg :| []) field)  -- mkSetField a field b calculates a set_field @field expression.--- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").+-- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' to a on b").+-- NB: the order of aruments is specified by GHC Proposal 583: HasField redesign. mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn mkSetField set_field a (L _ (FieldLabelString field)) b =-  genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field)  a) b+  genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) b) a -mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn]-mkGet get_field l@(r : _) (L _ (FieldLabelString field)) =-  wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l-mkGet _ [] _ = panic "mkGet : The impossible has happened!"+mkGet :: Name -> NonEmpty (LHsExpr GhcRn) -> LocatedAn NoEpAnns FieldLabelString -> NonEmpty (LHsExpr GhcRn)+mkGet get_field l@(r :| _) (L _ (FieldLabelString field)) =+  wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) NE.<| l  mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)@@ -2878,10 +2878,10 @@ mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn) mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))   = let {-      ; flds = map (fmap (unLoc . dfoLabel)) flds'+      ; flds = NE.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.+      ; getters = \a -> foldl' (mkGet get_field) (a :| []) fields  -- Ordered from deep to shallow.           -- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a]       ; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow.           -- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)]
compiler/GHC/Rename/Fixity.hs view
@@ -183,7 +183,7 @@       -- loadInterfaceForName will find B.hi even if B is a hidden module,       -- and that's what we want.       = do { iface <- loadInterfaceForName doc name-           ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ+           ; let mb_fix = mi_fix_fn iface occ            ; let msg = case mb_fix of                             Nothing ->                                   text "looking up name" <+> ppr name
compiler/GHC/Rename/HsType.hs view
@@ -14,14 +14,14 @@         -- Type related stuff         rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,         rnLHsKind, rnLHsTypeArgs,-        rnHsSigType, rnHsWcType, rnHsTyLit, rnHsArrowWith,+        rnHsSigType, rnHsWcType, rnHsTyLit, rnHsMultAnnWith,         HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, rnHsPatSigKind,         newTyVarNameRn,-        rnConDeclFields,+        rnHsConDeclRecFields,         lookupField, mkHsOpTyRn,         rnLTyVar, -        rnScaledLHsType,+        rnHsConDeclField,          -- Precence related stuff         NegationHandling(..),@@ -30,6 +30,7 @@          -- Binding related stuff         bindHsOuterTyVarBndrs, bindHsForAllTelescope,+        bindHsForAllTelescopes,         bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),         rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,         FreeKiTyVars, filterInScopeM,@@ -37,6 +38,7 @@         extractHsTysRdrTyVars, extractRdrKindSigVars,         extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,         extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,+        extractHsForAllTelescopes,         nubL, nubN,          -- Error helpers@@ -450,14 +452,19 @@ rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys -rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs)-                                  -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)-rnScaledLHsType doc (HsScaled w ty) = do-  (w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w-  (ty', fvs) <- rnLHsType doc ty-  return (HsScaled w' ty', fvs `plusFV` fvs_w)+rnHsConDeclField :: HsDocContext -> HsConDeclField GhcPs+                 -> RnM (HsConDeclField GhcRn, FreeVars)+rnHsConDeclField doc = rnHsConDeclFieldTyKi (mkTyKiEnv doc TypeLevel RnTypeBody) +rnHsConDeclFieldTyKi :: RnTyKiEnv -> HsConDeclField GhcPs+                     -> RnM (HsConDeclField GhcRn, FreeVars)+rnHsConDeclFieldTyKi env cdf@(CDF { cdf_multiplicity, cdf_type, cdf_doc }) = do+  (w , fvs_w) <- rnHsMultAnnWith (rnLHsTyKi env) cdf_multiplicity+  (ty, fvs) <- rnLHsTyKi env cdf_type+  doc <- traverse rnLHsDoc cdf_doc+  return (cdf { cdf_multiplicity = w, cdf_type = ty, cdf_doc = doc }, fvs `plusFV` fvs_w) + rnHsType  :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty @@ -549,16 +556,17 @@        ; when (isDataConName name && not (isPromoted ip)) $          -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.             addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)-       ; return (HsTyVar noAnn ip (L loc name), unitFV name) }+       ; return (HsTyVar noAnn ip (L loc $ WithUserRdr rdr_name name), unitFV name) }  rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)   = setSrcSpan (getLocA l_op) $-    do  { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op+    do  { let op_rdr = unLoc l_op+        ; (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op         ; let op_name = unLoc l_op'         ; fix   <- lookupTyFixityRn l_op'         ; (ty1', fvs2) <- rnLHsTyKi env ty1         ; (ty2', fvs3) <- rnLHsTyKi env ty2-        ; res_ty <- mkHsOpTyRn prom l_op' fix ty1' ty2'+        ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2'         ; when (isDataConName op_name && not (isPromoted prom)) $             addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)         ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }@@ -567,35 +575,10 @@   = do { (ty', fvs) <- rnLHsTyKi env ty        ; return (HsParTy noAnn ty', fvs) } -rnHsTyKi env (HsBangTy x b ty)-  = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsBangTy x b ty', fvs) }--rnHsTyKi env ty@(HsRecTy _ flds)-  = do { let ctxt = rtke_ctxt env-       ; fls          <- get_fields ctxt-       ; (flds', fvs) <- rnConDeclFields ctxt fls flds-       ; return (HsRecTy noExtField flds', fvs) }-  where-    get_fields ctxt@(ConDeclCtx names)-      = do res <- concatMapM (lookupConstructorFields . unLoc) names-           if equalLength res names-           -- Lookup can fail when the record syntax is incorrect, e.g.-           -- data D = D Int { fld :: Bool }. See T7943.-           then return res-           else err ctxt-    get_fields ctxt = err ctxt--    err ctxt =-      do { addErr $-            TcRnWithHsDocContext ctxt $-            TcRnIllegalRecordSyntax (Left ty)-         ; return [] }- rnHsTyKi env (HsFunTy u mult ty1 ty2)   = do { (ty1', fvs1) <- rnLHsTyKi env ty1        ; (ty2', fvs2) <- rnLHsTyKi env ty2-       ; (mult', w_fvs) <- rnHsArrow env mult+       ; (mult', w_fvs) <- rnHsMultAnnWith (rnLHsTyKi env) mult        ; return (HsFunTy u mult' ty1' ty2'                 , plusFVs [fvs1, fvs2, w_fvs]) } @@ -662,7 +645,7 @@        ; return (HsDocTy x ty' haddock_doc', fvs) }  -- See Note [Renaming HsCoreTys]-rnHsTyKi env (XHsType ty)+rnHsTyKi env (XHsType (HsCoreTy ty))   = do mapM_ (check_in_scope . nameRdrName) fvs_list        return (XHsType ty, fvs)   where@@ -675,8 +658,25 @@       when (isNothing mb_name) $         addErr $           TcRnWithHsDocContext (rtke_ctxt env) $-            TcRnNotInScope (notInScopeErr WL_LocalOnly rdr_name) rdr_name [] []+            TcRnNotInScope (notInScopeErr WL_LocalOnly rdr_name) rdr_name +rnHsTyKi env ty@(XHsType (HsBangTy _ bang (L _ inner))) = do+  -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),+  -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of+  -- bangs are invalid, so fail. (#7210, #14761)+  addErr $+    TcRnWithHsDocContext (rtke_ctxt env) $+      TcRnUnexpectedAnnotation ty bang+  rnHsTyKi env inner++rnHsTyKi env ty@(XHsType (HsRecTy {})) = do+  -- Record types (which only show up temporarily in constructor+  -- signatures) should have been removed by now+  addErr $+    TcRnWithHsDocContext (rtke_ctxt env) $+      TcRnIllegalRecordSyntax ty+  return (HsWildCardTy noExtField, emptyFVs) -- trick to avoid `failWithTc`+ rnHsTyKi env ty@(HsExplicitListTy _ ip tys)   = do { checkDataKinds env ty        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys@@ -703,15 +703,12 @@ rnHsTyLit (HsCharTy x c) = pure (HsCharTy x c)  -rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)-rnHsArrow env = rnHsArrowWith (rnLHsTyKi env)--rnHsArrowWith :: (LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars))-              -> HsArrowOf (LocatedA (mult GhcPs)) GhcPs-              -> RnM (HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)-rnHsArrowWith _rn (HsUnrestrictedArrow _) = pure (HsUnrestrictedArrow noExtField, emptyFVs)-rnHsArrowWith _rn (HsLinearArrow _) = pure (HsLinearArrow noExtField, emptyFVs)-rnHsArrowWith rn (HsExplicitMult _ p)+rnHsMultAnnWith :: (LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars))+                  -> HsMultAnnOf (LocatedA (mult GhcPs)) GhcPs+                  -> RnM (HsMultAnnOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)+rnHsMultAnnWith _rn (HsUnannotated _) = pure (HsUnannotated noExtField, emptyFVs)+rnHsMultAnnWith _rn (HsLinearAnn _) = pure (HsLinearAnn noExtField, emptyFVs)+rnHsMultAnnWith rn (HsExplicitMult _ p)   =  (\(mult, fvs) -> (HsExplicitMult noExtField mult, fvs)) <$> rn p  {-@@ -825,6 +822,7 @@        ExprWithTySigCtx {} -> True        PatCtx {}           -> True        RuleCtx {}          -> True+       SpecECtx {}         -> True        FamPatCtx {}        -> True   -- Not named wildcards though        GHCiCtx {}          -> True        HsTypeCtx {}        -> True@@ -1144,6 +1142,17 @@         checkForAllTelescopeWildcardBndrs doc bndrs'         thing_inside $ mkHsForAllInvisTele noAnn bndrs' +bindHsForAllTelescopes :: HsDocContext+                       -> [HsForAllTelescope GhcPs]+                       -> ([HsForAllTelescope GhcRn] -> RnM (a, FreeVars))+                       -> RnM (a, FreeVars)+bindHsForAllTelescopes _ [] thing_inside =+  thing_inside []+bindHsForAllTelescopes doc (tele:teles) thing_inside =+  bindHsForAllTelescope  doc tele  $ \tele'  ->+  bindHsForAllTelescopes doc teles $ \teles' ->+    thing_inside (tele':teles')+ -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type checkForAllTelescopeWildcardBndrs :: HsDocContext                                   -> [LHsTyVarBndr flag (GhcPass p)]@@ -1310,34 +1319,33 @@ {- ********************************************************* *                                                       *-        ConDeclField+        HsConDeclRecField *                                                       * ********************************************************* -When renaming a ConDeclField, we have to find the FieldLabel+When renaming a HsConDeclRecField, we have to find the FieldLabel associated with each field.  But we already have all the FieldLabels available (since they were brought into scope by GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an argument, build a map and look them up. -} -rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]-                -> RnM ([LConDeclField GhcRn], FreeVars)+rnHsConDeclRecFields :: HsDocContext -> [FieldLabel] -> [LHsConDeclRecField GhcPs]+                -> RnM ([LHsConDeclRecField GhcRn], FreeVars) -- Also called from GHC.Rename.Module -- No wildcards can appear in record fields-rnConDeclFields ctxt fls fields+rnHsConDeclRecFields ctxt fls fields    = mapFvRn (rnField fl_env env) fields   where     env    = mkTyKiEnv ctxt TypeLevel RnTypeBody     fl_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ] -rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs-        -> RnM (LConDeclField GhcRn, FreeVars)-rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))+rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LHsConDeclRecField GhcPs+        -> RnM (LHsConDeclRecField GhcRn, FreeVars)+rnField fl_env env (L l (HsConDeclRecField _ names ty))   = do { let new_names = map (fmap (lookupField fl_env)) names-       ; (new_ty, fvs) <- rnLHsTyKi env ty-       ; haddock_doc' <- traverse rnLHsDoc haddock_doc-       ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc')+       ; (new_ty, fvs) <- rnHsConDeclFieldTyKi env ty+       ; return (L l (HsConDeclRecField noExtField new_names new_ty)                 , fvs) }  lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn@@ -1346,7 +1354,7 @@   where     lbl = occNameFS $ rdrNameOcc rdr     sel = flSelector-        $ expectJust "lookupField"+        $ expectJust         $ lookupFsEnv fl_env lbl  {-@@ -1381,19 +1389,19 @@ --------------- -- Building (ty1 `op1` (ty2a `op2` ty2b)) mkHsOpTyRn :: PromotionFlag-           -> LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn+           -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn -> LHsType GhcRn            -> RnM (HsType GhcRn)  mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b))-  = do  { fix2 <- lookupTyFixityRn op2+  = do  { fix2 <- lookupTyFixityRn (fmap getName op2)         ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 }  mkHsOpTyRn prom1 op1 _ ty1 ty2              -- Default case, no rearrangement   = return (HsOpTy noExtField prom1 ty1 op1 ty2)  ----------------mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn-            -> PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn+mk_hs_op_ty :: PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn+            -> PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn             -> LHsType GhcRn -> SrcSpanAnnA             -> RnM (HsType GhcRn) mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2@@ -1466,10 +1474,10 @@ ----------------------------  get_op :: LHsExpr GhcRn -> OpName--- An unbound name could be either HsVar or HsUnboundVar+-- An unbound name could be either HsVar or (HsHole (HoleVar _, _)) -- See GHC.Rename.Expr.rnUnboundVar get_op (L _ (HsVar _ n))                 = NormalOp (unLoc n)-get_op (L _ (HsUnboundVar _ uv))         = UnboundOp uv+get_op (L _ (HsHole (HoleVar (L _ uv)))) = UnboundOp uv get_op (L _ (XExpr (HsRecSelRn fld)))    = RecFldOp fld get_op other                             = pprPanic "get_op" (ppr other) @@ -1496,11 +1504,12 @@ not_op_app _          = True  ---------------------------------------mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn+mkConOpPatRn :: LocatedN (WithUserRdr Name)+             -> Fixity -> LPat GhcRn -> LPat GhcRn              -> RnM (Pat GhcRn)  mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p1a p1b))) p2-  = do  { fix1 <- lookupFixityRn (unLoc op1)+  = do  { fix1 <- lookupFixityRn (getName op1)         ; let (nofix_error, associate_right) = compareFixity fix1 fix2          ; if nofix_error then do@@ -1508,7 +1517,7 @@                                (NormalOp (unLoc op2),fix2)                 ; return $ ConPat                     { pat_con_ext = noExtField-                    , pat_con = op2+                    , pat_con  = op2                     , pat_args = InfixCon p1 p2                     }                 }@@ -1569,14 +1578,14 @@ checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () checkPrec op (ConPat NoExtField op1 (InfixCon _ _)) right = do     op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op-    op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)+    op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (getName op1)     let         inf_ok = op1_prec > op_prec ||                  (op1_prec == op_prec &&                   (op1_dir == InfixR && op_dir == InfixR && right ||                    op1_dir == InfixL && op_dir == InfixL && not right)) -        info  = (NormalOp op,          op_fix)+        info  = (NormalOp (noUserRdr op), op_fix)         info1 = (NormalOp (unLoc op1), op1_fix)         (infol, infor) = if right then (info, info1) else (info1, info)     unless inf_ok (precParseErr infol infor)@@ -1606,7 +1615,7 @@  -- | Look up the fixity for an operator name. lookupFixityOp :: OpName -> RnM Fixity-lookupFixityOp (NormalOp n)  = lookupFixityRn n+lookupFixityOp (NormalOp n)  = lookupFixityRn (getName n) lookupFixityOp NegateOp      = lookupFixityRn negateName lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (occName u)) lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f@@ -1628,7 +1637,7 @@   = addErr $ TcRnSectionPrecedenceError op arg_op section  is_unbound :: OpName -> Bool-is_unbound (NormalOp n) = isUnboundName n+is_unbound (NormalOp n) = isUnboundName (getName n) is_unbound UnboundOp{}  = True is_unbound _            = False @@ -2031,7 +2040,7 @@   HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars extractConDeclGADTDetailsTyVars con_args = case con_args of   PrefixConGADT _ args    -> extract_scaled_ltys args-  RecConGADT _ (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds+  RecConGADT _ (L _ flds) -> extract_scaled_ltys $ map (cdrf_spec . unLoc) $ flds  -- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order:@@ -2047,13 +2056,14 @@ extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars extract_lctxt ctxt = extract_ltys (unLoc ctxt) -extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]+extract_scaled_ltys :: [HsConDeclField GhcPs]                     -> FreeKiTyVars -> FreeKiTyVars extract_scaled_ltys args acc = foldr extract_scaled_lty acc args -extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs)+extract_scaled_lty :: HsConDeclField GhcPs                    -> FreeKiTyVars -> FreeKiTyVars-extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc+extract_scaled_lty (CDF { cdf_multiplicity, cdf_type }) acc+  = extract_lty cdf_type $ extract_hs_mult_ann cdf_multiplicity acc  extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars extract_ltys tys acc = foldr extract_lty acc tys@@ -2062,10 +2072,6 @@ extract_lty (L _ ty) acc   = case ty of       HsTyVar _ _  ltv            -> extract_tv ltv acc-      HsBangTy _ _ ty             -> extract_lty ty acc-      HsRecTy _ flds              -> foldr (extract_lty-                                            . cd_fld_type . unLoc) acc-                                           flds       HsAppTy _ ty1 ty2           -> extract_lty ty1 $                                      extract_lty ty2 acc       HsAppKindTy _ ty k          -> extract_lty ty $@@ -2074,7 +2080,7 @@       HsTupleTy _ _ tys           -> extract_ltys tys acc       HsSumTy _ tys               -> extract_ltys tys acc       HsFunTy _ m ty1 ty2         -> extract_lty ty1 $-                                     extract_hs_arrow m $ -- See Note [Ordering of implicit variables]+                                     extract_hs_mult_ann m $ -- See Note [Ordering of implicit variables]                                      extract_lty ty2 acc       HsIParamTy _ _ ty           -> extract_lty ty acc       HsOpTy _ _ ty1 tv ty2       -> extract_lty ty1 $@@ -2115,10 +2121,9 @@ extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =   extractHsOuterTvBndrs outer_bndrs $ extract_lty body [] -extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->-                   FreeKiTyVars-extract_hs_arrow (HsExplicitMult _ p) acc = extract_lty p acc-extract_hs_arrow _ acc = acc+extract_hs_mult_ann :: HsMultAnn GhcPs -> FreeKiTyVars -> FreeKiTyVars+extract_hs_mult_ann (HsExplicitMult _ p) acc = extract_lty p acc+extract_hs_mult_ann _ acc = acc  extract_hs_for_all_telescope :: HsForAllTelescope GhcPs                              -> FreeKiTyVars -- Accumulator@@ -2138,6 +2143,14 @@   case outer_bndrs of     HsOuterImplicit{}                  -> body_fvs     HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs++extractHsForAllTelescopes :: [HsForAllTelescope GhcPs]+                          -> FreeKiTyVars -- Free in body+                          -> FreeKiTyVars -- Free in result+extractHsForAllTelescopes []           body_fvs = body_fvs+extractHsForAllTelescopes (tele:teles) body_fvs =+  extract_hs_for_all_telescope tele [] $+  extractHsForAllTelescopes teles body_fvs  extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]                     -> FreeKiTyVars  -- Accumulator
compiler/GHC/Rename/Module.hs view
@@ -1,13 +1,16 @@  {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE RecursiveDo         #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE LambdaCase          #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -24,26 +27,23 @@ import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )  import GHC.Hs-import GHC.Types.FieldLabel-import GHC.Types.Name.Reader+ import GHC.Rename.HsType import GHC.Rename.Bind import GHC.Rename.Doc import GHC.Rename.Env import GHC.Rename.Utils ( mapFvRn, bindLocalNames                         , checkDupRdrNames, bindLocalNamesFV-                        , checkShadowedRdrNames, warnUnusedTypePatterns-                        , newLocalBndrsRn+                        , warnUnusedTypePatterns                         , noNestedForallsContextsErr                         , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names+ import GHC.Tc.Errors.Types-import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin ( TypedThing(..) ) -import GHC.Types.ForeignCall ( CCallTarget(..) ) import GHC.Unit import GHC.Unit.Module.Warnings import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName@@ -51,23 +51,30 @@                         , semigroupClassName, sappendName                         , monoidClassName, mappendName                         )++import GHC.Types.FieldLabel+import GHC.Types.Name.Reader+import GHC.Types.ForeignCall ( CCallTarget(..) ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env-import GHC.Utils.Outputable-import GHC.Types.Basic (Arity)-import GHC.Types.Basic  ( TypeOrKind(..) )-import GHC.Data.FastString+import GHC.Types.Basic  ( VisArity, TyConFlavour(..), TypeOrKind(..), RuleName )+import GHC.Types.GREInfo (ConLikeInfo (..), ConInfo, mkConInfo, conInfoFields)+import GHC.Types.Hint (SigLike(..))+import GHC.Types.Unique.Set import GHC.Types.SrcLoc as SrcLoc+ import GHC.Driver.DynFlags-import GHC.Utils.Misc   ( lengthExceeds, partitionWith )-import GHC.Utils.Panic import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)++import GHC.Utils.Misc   ( lengthExceeds )+import GHC.Utils.Panic+import GHC.Utils.Outputable++import GHC.Data.FastString import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses )-import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)+import GHC.Data.Graph.Directed ( SCC, flattenSCC, Node(..)                                , stronglyConnCompFromEdgedVerticesUniq )-import GHC.Types.GREInfo (ConLikeInfo (..), ConInfo, mkConInfo, conInfoFields)-import GHC.Types.Unique.Set import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt import GHC.Core.DataCon ( isSrcStrict )@@ -75,7 +82,6 @@ import Control.Monad import Control.Arrow ( first ) import Data.Foldable ( toList, for_ )-import Data.List ( mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..), head, nonEmpty ) import Data.Maybe ( isNothing, fromMaybe, mapMaybe, maybeToList ) import qualified Data.Set as Set ( difference, fromList, toList, null )@@ -216,7 +222,8 @@    last_tcg_env0 <- getGblEnv ;    let { last_tcg_env =             last_tcg_env0-              { tcg_complete_matches = tcg_complete_matches last_tcg_env0 ++ localCompletePragmas sigs' }+              { tcg_complete_matches = tcg_complete_matches last_tcg_env0 ++ localCompletePragmas sigs'+                                      , tcg_complete_match_env = tcg_complete_match_env last_tcg_env0 ++ localCompletePragmas sigs'}        } ;    -- (I) Compute the results and return    let {rn_group = HsGroup { hs_ext     = noExtField,@@ -293,7 +300,7 @@     rn_deprec w@(Warning (ns_spec, _) rdr_names txt)        -- ensures that the names are defined locally-     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what ns_spec . unLoc)+     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt SigLikeDeprecation ns_spec . unLoc)                                 rdr_names           ; unlessXOptM LangExt.ExplicitNamespaces $             when (ns_spec /= NoNamespaceSpecifier) $@@ -304,8 +311,6 @@   -- as we might hit multiple different NameSpaces when looking up   -- (e.g. deprecating both a variable and a record field). -   what = text "deprecation"-    warn_rdr_dups = find_dup_warning_names                    $ concatMap (\(L _ (Warning (ns_spec, _) ns _)) -> (ns_spec,) <$> ns) decls @@ -342,9 +347,10 @@  rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) rnAnnDecl ann@(HsAnnotation (_, s) provenance expr)-  = addErrCtxt (annCtxt ann) $+  = addErrCtxt (AnnCtxt ann) $     do { (provenance', provenance_fvs) <- rnAnnProvenance provenance-       ; (expr', expr_fvs) <- setStage (Splice Untyped) $+       ; cur_level <- getThLevel+       ; (expr', expr_fvs) <- setThLevel (Splice Untyped cur_level) $                               rnLExpr expr        ; return (HsAnnotation (noAnn, s) provenance' expr',                  provenance_fvs `plusFV` expr_fvs) }@@ -354,9 +360,9 @@ rnAnnProvenance provenance = do     provenance' <- case provenance of       ValueAnnProvenance n -> ValueAnnProvenance-                          <$> lookupLocatedTopBndrRnN n+                          <$> lookupLocatedTopBndrRnN WL_Term n       TypeAnnProvenance n  -> TypeAnnProvenance-                          <$> lookupLocatedTopConstructorRnN n+                          <$> lookupLocatedTopBndrRnN WL_Type n       ModuleAnnProvenance  -> return ModuleAnnProvenance     return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) @@ -371,7 +377,7 @@ rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) rnDefaultDecl (DefaultDecl _ mb_cls tys)   = do {-       ; mb_cls' <- traverse (traverse lookupOccRn) mb_cls+       ; mb_cls' <- traverse (traverse $ lookupOccRn WL_TyCon) mb_cls        ; (tys', ty_fvs) <- rnLHsTypes doc_str tys        ; return (DefaultDecl noExtField mb_cls' tys', ty_fvs) }   where@@ -388,7 +394,7 @@ rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })   = do { topEnv :: HscEnv <- getTopEnv-       ; name' <- lookupLocatedTopBndrRnN name+       ; name' <- lookupLocatedTopBndrRnN WL_TermVariable name        ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty          -- Mark any PackageTarget style imports as coming from the current package@@ -400,7 +406,7 @@                                , fd_fi = spec' }, fvs) }  rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })-  = do { name' <- lookupLocatedOccRn name+  = do { name' <- lookupLocatedOccRn WL_TermVariable name        ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty        ; return (ForeignExport { fd_e_ext = noExtField                                , fd_name = name', fd_sig_ty = ty'@@ -559,9 +565,10 @@     isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name     isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = L _ []                                              , m_grhss = grhss })])}-        | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss+        | GRHSs _ (L _ (GRHS _ [] body) :| []) lbinds <- grhss         , EmptyLocalBinds _ <- lbinds-        , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)+        , HsVar _ lrhsName  <- unLoc body+        = Just (getName lrhsName)     isAliasMG _ = Nothing      addWarnNonCanonicalMonoid reason =@@ -579,34 +586,59 @@                            , cid_sigs = uprags, cid_tyfam_insts = ats                            , cid_overlap_mode = oflag                            , cid_datafam_insts = adts })-  = do { checkInferredVars ctxt inst_ty-       ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty-       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'-             -- Check if there are any nested `forall`s or contexts, which are-             -- illegal in the type of an instance declaration (see-             -- Note [No nested foralls or contexts in instance types] in-             -- GHC.Hs.Type)...-             mb_nested_msg = noNestedForallsContextsErr-                               NFC_InstanceHead head_ty'-             -- ...then check if the instance head is actually headed by a-             -- class type constructor...-             eith_cls = case hsTyGetAppHead_maybe head_ty' of-               Just (L _ cls) -> Right cls-               Nothing        ->-                  Left-                   ( getLocA head_ty'-                   , TcRnIllegalInstance $-                       IllegalClassInstance (HsTypeRnThing $ unLoc head_ty') $-                       IllegalInstanceHead $ InstHeadNonClass Nothing-                   )+  = do { rec { let ctxt = ClassInstanceCtx head_ty'+             ; checkInferredVars ctxt inst_ty+             ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty+             ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'+             }+      ; env <- getGlobalRdrEnv+      ; let+          -- Check if there are any nested `forall`s or contexts, which are+          -- illegal in the type of an instance declaration (see+          -- Note [No nested foralls or contexts in instance types] in+          -- GHC.Hs.Type)...+          mb_nested_msg = noNestedForallsContextsErr NFC_InstanceHead head_ty'+          -- ...then check if the instance head is actually headed by a+          -- class type constructor...+          instance_head :: Either IllegalInstanceHeadReason Name+          instance_head =+           case hsTyGetAppHead_maybe head_ty' of+             Just (L _ nm_with_rdr) ->+               let nm = getName nm_with_rdr in+               case lookupGRE_Name env nm of+                 Just (GRE { gre_info = IAmTyCon flav }) ->+                   if+                     | flav == ClassFlavour+                     -> Right nm+                     | flav == AbstractTypeFlavour+                     -> Left $ InstHeadAbstractClass nm_with_rdr+                     | otherwise+                     -> Left $ InstHeadNonClassHead $ InstNonClassTyCon nm_with_rdr flav+                 _ ->+                  -- The head of the instance head is out of scope;+                  -- we'll deal with that later. Continue for now.+                  Right nm++             Nothing ->+               Left $ InstHeadNonClassHead InstNonTyCon+          eith_cls =+            case instance_head of+              Right cls -> Right cls+              Left illegal_head_reason ->+                 Left+                  ( getLocA head_ty'+                  , TcRnIllegalInstance $+                      IllegalClassInstance (HsTypeRnThing $ unLoc head_ty') $+                      IllegalInstanceHead illegal_head_reason+                  )          -- ...finally, attempt to retrieve the class type constructor, failing          -- with an error message if there isn't one. To avoid excessive          -- amounts of error messages, we will only report one of the errors          -- from mb_nested_msg or eith_cls at a time.        ; cls <- case (mb_nested_msg, eith_cls) of            (Nothing,   Right cls) -> pure cls-           (Just err1, _)         -> bail_out err1-           (_,         Left err2) -> bail_out err2+           (Just err1, _)         -> bail_out ctxt err1+           (_,         Left err2) -> bail_out ctxt err2            -- Rename the bindings           -- The typechecker (not the renamer) checks that all@@ -646,14 +678,12 @@              --     strange, but should not matter (and it would be more work              --     to remove the context).   where-    ctxt    = GenericCtx $ text "an instance declaration"-     -- The instance is malformed. We'd still like to make *some* progress     -- (rather than failing outright), so we report an error and continue for     -- as long as we can. Importantly, this error should be thrown before we     -- reach the typechecker, lest we encounter different errors that are     -- hopelessly confusing (such as the one in #16114).-    bail_out (l, err_msg) = do+    bail_out ctxt (l, err_msg) = do       addErrAt l $ TcRnWithHsDocContext ctxt err_msg       pure $ mkUnboundName (mkTcOccFS (fsLit "<class>")) @@ -717,7 +747,7 @@               groups :: [NonEmpty (LocatedN RdrName)]              groups = equivClasses cmpLocated pat_kity_vars-       ; nms_dups <- mapM (lookupOccRn . unLoc) $+       ; nms_dups <- mapM (lookupOccRn WL_TyVar . unLoc) $                         [ tv | (tv :| (_:_)) <- groups ]              -- Add to the used variables              --  a) any variables that appear *more than once* on the LHS@@ -1160,65 +1190,23 @@                          , rds_rules = rn_rules }, fvs) }  rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)-rnHsRuleDecl (HsRule { rd_ext  = (_, st)-                     , rd_name = rule_name-                     , rd_act  = act-                     , rd_tyvs = tyvs-                     , rd_tmvs = tmvs-                     , rd_lhs  = lhs-                     , rd_rhs  = rhs })-  = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs-       ; checkDupRdrNames rdr_names_w_loc-       ; checkShadowedRdrNames rdr_names_w_loc-       ; names <- newLocalBndrsRn rdr_names_w_loc-       ; let doc = RuleCtx (unLoc rule_name)-       ; bindRuleTyVars doc tyvs $ \ tyvs' ->-         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->+rnHsRuleDecl (HsRule { rd_ext   = (_, st)+                     , rd_name  = lrule_name@(L _ rule_name)+                     , rd_act   = act+                     , rd_bndrs = bndrs+                     , rd_lhs   = lhs+                     , rd_rhs   = rhs })+  = bindRuleBndrs (RuleCtx rule_name) bndrs $ \tm_names bndrs' ->     do { (lhs', fv_lhs') <- rnLExpr lhs        ; (rhs', fv_rhs') <- rnLExpr rhs-       ; checkValidRule (unLoc rule_name) names lhs' fv_lhs'-       ; return (HsRule { rd_ext  = (HsRuleRn fv_lhs' fv_rhs', st)-                        , rd_name = rule_name-                        , rd_act  = act-                        , rd_tyvs = tyvs'-                        , rd_tmvs = tmvs'-                        , rd_lhs  = lhs'-                        , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }-  where-    get_var :: RuleBndr GhcPs -> LocatedN RdrName-    get_var (RuleBndrSig _ v _) = v-    get_var (RuleBndr _ v)      = v--bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs-               -> [LRuleBndr GhcPs] -> [Name]-               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))-               -> RnM (a, FreeVars)-bindRuleTmVars doc tyvs vars names thing_inside-  = go vars names $ \ vars' ->-    bindLocalNamesFV names (thing_inside vars')-  where-    go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside-      = go vars ns $ \ vars' ->-        thing_inside (L l (RuleBndr noAnn (L loc n)) : vars')--    go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)-       (n : ns) thing_inside-      = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' ->-        go vars ns $ \ vars' ->-        thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars')--    go [] [] thing_inside = thing_inside []-    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)--    bind_free_tvs = case tyvs of Nothing -> AlwaysBind-                                 Just _  -> NeverBind--bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]-               -> (Maybe [LHsTyVarBndr () GhcRn]  -> RnM (b, FreeVars))-               -> RnM (b, FreeVars)-bindRuleTyVars doc (Just bndrs) thing_inside-  = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just)-bindRuleTyVars _ _ thing_inside = thing_inside Nothing+       ; checkValidRule rule_name tm_names lhs' fv_lhs'+       ; return (HsRule { rd_ext   = (HsRuleRn fv_lhs' fv_rhs', st)+                        , rd_name  = lrule_name+                        , rd_act   = act+                        , rd_bndrs = bndrs'+                        , rd_lhs   = lhs'+                        , rd_rhs   = rhs' }+                , fv_lhs' `plusFV` fv_rhs') }  {- Note [Rule LHS validity checking]@@ -1245,7 +1233,7 @@ So we should accommodate them. -} -checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()+checkValidRule :: RuleName -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () checkValidRule rule_name ids lhs' fv_lhs'   = do  {       -- Check for the form of the LHS           case (validRuleLhs ids lhs') of@@ -1269,7 +1257,7 @@     check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2     check (HsAppType _ e _)               = checkl e     check (HsVar _ lv)-      | (unLoc lv) `notElem` foralls      = Nothing+      | getName lv `notElem` foralls      = Nothing     -- See Note [Parens on the LHS of a RULE]     check (HsPar _ e)                     = checkl e     check other                           = Just other  -- Failure@@ -1299,7 +1287,7 @@   = TcRnIllegalRuleLhs errReason name lhs bad_e   where     errReason = case bad_e of-      HsUnboundVar _ uv ->+      HsHole (HoleVar (L _ uv)) ->         UnboundVariable uv $ notInScopeErr WL_Global uv       _ -> IllegalExpression @@ -1322,13 +1310,12 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. -Note [Dependency analysis of type, class, and instance decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A TyClGroup represents a strongly connected components of-type/class/instance decls, together with the role annotations for the-type/class declarations.  The renamer uses strongly connected-component analysis to build these groups.  We do this for a number of-reasons:+Note [Dependency analysis of type and class decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A TyClGroup represents a strongly connected component of type/class/instance+decls, together with the role annotations and standalone kind signatures for the+type/class declarations. The renamer uses strongly connected component analysis+to build these groups. We do this for a number of reasons:  * Improve kind error messages. Consider @@ -1340,90 +1327,153 @@   inference together, you might get an error reported in S, which   is jolly confusing.  See #4875 - * Increase kind polymorphism.  See GHC.Tc.TyCl   Note [Grouping of type and class declarations] -Why do the instance declarations participate?  At least two reasons+What about instances? Based on a number of tickets (#12088, #12239, #14668,+#15561, #16410, #16448, #16693, #19611, #20875, #21172, #22257, #25238, #25834,+etc) we concluded that we cannot handle them at this stage. -* Consider (#11348)+It is not possible, by looking at the free variables of a declaration, to+determine which instances a declaration depends on; furthermore, it is not+possible to discover dependencies between instances, for the same reason. -     type family F a-     type instance F Int = Bool+Previously GHC inserted instances at the earliest positions where their FVs are+bound, but it only helped with a subset of tickets. The current approach is to+accept that the dependency analysis here is incomplete and recover in the kind+checker with a retrying mechanism. See Note [Retrying TyClGroups] in GHC.Tc.TyCl -     data R = MkR (F Int)+------------------------------------+So much for why we want SCCs.  What about how and when we construct them? -     type Foo = 'MkR 'True+First, an overview:+  (TCDEP1) Flatten TyClGroups from the parser+  (TCDEP2) Rename the type/class declarations, standalone kind signatures, role+           declarations, and instances individually+  (TCDEP3) Preprocess FVs and build a dependency graph+  (TCDEP4) Find strongly connected components (SCCs) of declarations+  (TCDEP5) Attach roles and kind signatures to the appropriate SCC+  (TCDEP6) Create one singleton "SCC" per instance and put them at the end -  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't-  know that unless we've looked at the type instance declaration for F-  before kind-checking Foo.+And now the deep dive: -* Another example is this (#3990).+(TCDEP1) We start with a `HsGroup GhcPs`, containing a `[TyClGroup GhcPs]`:+  a big pile of declarations. It is not important how the parser distributes+  declarations across those TyClGroups, as the first thing we do in `rnTyClDecls`+  is flatten them using a few helpers: -     data family Complex a-     data instance Complex Double = CD {-# UNPACK #-} !Double-                                       {-# UNPACK #-} !Double+    tyClGroupTyClDecls = Data.List.concatMap group_tyclds+    tyClGroupInstDecls = Data.List.concatMap group_instds+    tyClGroupRoleDecls = Data.List.concatMap group_roles+    tyClGroupKindSigs  = Data.List.concatMap group_kisigs -     data T = T {-# UNPACK #-} !(Complex Double)+  In practice, the parser just puts all declarations in a single `TyClGroup`,+  so the `concatMap` is a no-op. -  Here, to generate the right kind of unpacked implementation for T,-  we must have access to the 'data instance' declaration.+(TCDEP2) Rename each declaration separately, yielding the following lists+  in `rnTyClDecls`: -* Things become more complicated when we introduce transitive-  dependencies through imported definitions, like in this scenario:+    tycls_w_fvs  :: [(LTyClDecl GhcRn, FreeVars)]+    instds_w_fvs :: [(LInstDecl GhcRn, FreeVars)]+    kisigs_w_fvs :: [(LStandaloneKindSig GhcRn, FreeVars)]+    role_annots  :: [LRoleAnnotDecl GhcRn] -      A.hs-        type family Closed (t :: Type) :: Type where-          Closed t = Open t+  The `FreeVars` are the free type/data constructors of the decl. For example: -        type family Open (t :: Type) :: Type+    type family F (a :: k)        -- FVs: {}+    data X = MkX Char (Maybe X)   -- FVs: {Char, Maybe, X}+    data Y = MkY X (Maybe Y)      -- FVs: {Maybe, Y, X}+    type instance F MkX = X       -- FVs: {F, MkX, X}+    type instance F MkY = Int     -- FVs: {F, MkY, Int} -      B.hs-        data Q where-          Q :: Closed Bool -> Q+(TCDEP3) Build a graph where each node is a `TyClDecl` keyed by its name, and+  its `FreeVars` give rise to edges. Happens in `depAnalTyClDecls`. Examples: -        type instance Open Int = Bool+    data A x = MkA x       -- node `A`, edges: {}+    data B x = MkB (A x)   -- node `B`, edges: {B -> A}+    data C = MkC (B C)     -- node `C`, edges: {C -> B, C -> C} -        type S = 'Q 'True+  The `FreeVars` are not used "as is" to create the edges. They first undergo a+  few transformations. -  Somehow, we must ensure that the instance Open Int = Bool is checked before-  the type synonym S. While we know that S depends upon 'Q depends upon Closed,-  we have no idea that Closed depends upon Open!+  (TCDEP3.fvs_kisig) If a standalone kind signature is present, add its free+    variables to those of the declaration. Consider: -  To accommodate for these situations, we ensure that an instance is checked-  before every @TyClDecl@ on which it does not depend. That's to say, instances-  are checked as early as possible in @tcTyAndClassDecls@.+      data A = MkA+      data B = MkB --------------------------------------So much for WHY.  What about HOW?  It's pretty easy:+      type P :: A -> Type           -- sig  FVs: {A, Type}+      data P x = MkP (Proxy MkB)    -- decl FVs: {Proxy, MkB} -(1) Rename the type/class, instance, and role declarations-    individually+    By adding the sig and decl FVs together, we get {A, Type, Proxy, MkB}.+    Then proceed to the next step. -(2) Do strongly-connected component analysis of the type/class decls,-    We'll make a TyClGroup for each SCC+  (TCDEP3.fvs_parent) Replace any mention of a (promoted) data constructor+    with its parent TyCon. Consider the FVs from the previous step: -    In this step we treat a reference to a (promoted) data constructor-    K as a dependency on its parent type.  Thus-        data T = K1 | K2-        data S = MkS (Proxy 'K1)-    Here S depends on 'K1 and hence on its parent T.+      the name set {A, Type, Proxy, MkB}+      turns into   {A, Type, Proxy, B} -    In this step we ignore instances; see-    Note [No dependencies on data instances]+    MkB does not get its own node in the graph, so an edge to it must actually+    point to B. -(3) Attach roles to the appropriate SCC+  (TCDEP3.fvs_nogbl) Filter out references to type constructors outside this+    `HsGroup`. They just clutter things up: -(4) Attach instances to the appropriate SCC.-    We add an instance decl to SCC when:-      all its free types/classes are bound in this SCC or earlier ones+      the name set {A, Type, Proxy, B}+      turns into   {A, B} -(5) We make an initial TyClGroup, with empty group_tyclds, for any-    (orphan) instances that affect only imported types/classes+  Note [Prepare TyClGroup FVs] describes these transformations in more detail.+  Back to our `P` example, the final nodes and edges are as follows: -Steps (3) and (4) are done by the (mapAccumL mk_group) call.+      data A = MkA    -- node `A`, edges: {}+      data B = MkB    -- node `B`, edges: {} +      type P :: A -> Type+      data P x = MkP (Proxy MkB)  -- node `P`, edges: {P -> A, P -> B}++(TCDEP4) Find strongly connected components (SCCs) of `TyClDecl`s.+  This happens immediately after building the dependency graph in+  `depAnalTyClDecls`. As the result, in `rnTyClDecls` we get++    tycl_sccs :: [SCC (LTyClDecl GhcRn, NameSet)]++  These SCCs are topologically sorted, but only according to lexical+  dependencies (i.e. dependencies that can be found by looking at the FVs).+  Non-lexical dependencies (i.e. dependencies on instances) are ignored because+  they can't be reliably found prior to type checking.++  More on that in Note [Retrying TyClGroups] in GHC.Tc.TyCl.++(TCDEP5) For each SCC, create a `TyClGroup GhcRn`. Standalone kind signatures+  and role annotations are looked up by name and included in the same+  `TyClGroup` as the corresponding type/class declarations.++  The extension field `group_ext` of `TyClGroup GhcRn` contains the dependencies+  of the SCC computed from FVs in step (TCDEP3), but /excluding/ the type+  constructors bound by the group itself. Example:++     -- TyClGroup: binds {Z}+     --            depends on {}+     data Z = MkZ      -- FVs: {}++     -- TyClGroup: binds {X, Y}+     --            depends on {Z} rather than {X, Y, Z}+     data X = MkX Y Z  -- FVs: {Y, Z}+     data Y = MkY X Z  -- FVs: {X, Z}++  Reason: `isReadyTyClGroup` in GHC.Tc.TyCl is a function that checks whether+  all of a TyClGroup's dependencies are present in the type checking env, and we+  wouldn't want it to consider a group to be "blocked" on its own declarations.++(TCDEP6) For each instance, create a singleton `TyClGroup GhcRn`, and put them+  all at the end, where their lexical dependencies are surely satisfied.+  More on that in Note [Put instances at the end].++  The `group_ext` field in an instance TyClGroup is set to the FVs of the+  instance, preprocessed much in the same way as declaration FVs in step+  (TCDEP3). See Note [Prepare TyClGroup FVs] for details.+ Note [No dependencies on data instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this@@ -1440,6 +1490,32 @@ Ugh.  For now we simply don't allow promotion of data constructors for data instances.  See Note [AFamDataCon: not promoting data family constructors] in GHC.Tc.Utils.Env++Note [Put instances at the end]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is no point including type family instances or class instances in the+graph for SCC analysis because instances are not referred to by name. We cannot+discover, by looking at the free variables of a declaration, what instances it+depends on.++Instead, we create one singleton "SCC" per instance using mkInstGroups and put+them at the end. This is simple and guarantees that the FVs of all instances are+bound in the preceding TyClGroups.++The problem is that if there are any declarations that depend on instances,+they're going to fail kind checking, because instances come after the+declarations. To account for that, the kind checker goes through a multipass+ordeal described in Note [Retrying TyClGroups] in GHC.Tc.TyCl.++One might ask, "why not insert instances at the earliest positions where their+FVs are bound?" Indeed, this sounds like a plausible solution, and GHC used to+do it at one point. However, there are many tickets (and now test cases)+demonstrating its inadequacy: #12088, #12239, #14668, #15561, #16410, #16448,+#16693, #19611, #20875, #21172, #22257, #25238, #25834, etc.++As to why we put each instance in its own group, as opposed to using just one+group with all the instances, the reason is that an instance may depend on+another instance, so we better add them to the environment one by one. -}  @@ -1447,7 +1523,8 @@             -> RnM ([TyClGroup GhcRn], FreeVars) -- Rename the declarations and do dependency analysis on them rnTyClDecls tycl_ds-  = do { -- Rename the type/class, instance, and role declarations+  = do { -- Flatten TyClGroups and rename each declaration individually.+         -- Steps (TCDEP1) and (TCDEP2) of Note [Dependency analysis of type and class decls]        ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds)        ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)        ; traceRn "rnTyClDecls" $@@ -1457,61 +1534,47 @@        ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)        ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) -       -- Do SCC analysis on the type/class decls+       -- Do SCC analysis on the type/class declarations.+       -- Steps (TCDEP3) and (TCDEP4) of Note [Dependency analysis of type and class decls]        ; rdr_env <- getGlobalRdrEnv        ; traceRn "rnTyClDecls SCC analysis" $            vcat [ text "rdr_env:" <+> ppr rdr_env ]-       ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs-             role_annot_env = mkRoleAnnotEnv role_annots+       ; let tycl_sccs = depAnalTyClDecls rdr_env tc_names kisig_fv_env tycls_w_fvs              (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs--             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs-             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map+             role_annot_env = mkRoleAnnotEnv role_annots -             first_group-               | null init_inst_ds = []-               | otherwise = [TyClGroup { group_ext    = noExtField-                                        , group_tyclds = []-                                        , group_kisigs = []-                                        , group_roles  = []-                                        , group_instds = init_inst_ds }]+       -- Construct renamed TyClGroups.+       -- Steps (TCDEP5) and (TCDEP6) of Note [Dependency analysis of type and class decls]+       ; let tycl_groups = map (mk_group role_annot_env kisig_env) tycl_sccs+             inst_groups = mkInstGroups rdr_env tc_names instds_w_fvs+             all_groups  = tycl_groups ++ inst_groups -             (final_inst_ds, groups)-                = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs+       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) -             all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`+       ; let all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`                        foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`                        foldr (plusFV . snd) emptyFVs kisigs_w_fvs -             all_groups = first_group ++ groups--       ; 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) }   where+    -- Construct a type/class declaration TyClGroup.+    -- Step (TCDEP5) of Note [Dependency analysis of type and class decls]     mk_group :: RoleAnnotEnv              -> KindSigEnv-             -> InstDeclFreeVarsMap-             -> SCC (LTyClDecl GhcRn)-             -> (InstDeclFreeVarsMap, TyClGroup GhcRn)-    mk_group role_env kisig_env inst_map scc-      = (inst_map', group)+             -> SCC (LTyClDecl GhcRn, NameSet)+             -> TyClGroup GhcRn+    mk_group role_env kisig_env scc = group       where-        tycl_ds              = flattenSCC scc-        bndrs                = map (tcdName . unLoc) tycl_ds-        roles                = getRoleAnnots bndrs role_env-        kisigs               = getKindSigs   bndrs kisig_env-        (inst_ds, inst_map') = getInsts      bndrs inst_map-        group = TyClGroup { group_ext    = noExtField+        (tycl_ds, nodes_deps) = unzip (flattenSCC scc)+        node_bndrs = map (tcdName . unLoc) tycl_ds+        deps = delFVs node_bndrs (plusFVs nodes_deps)+          -- (delFVs node_bndrs) removes the self-references.+          -- See Note [Prepare TyClGroup FVs]+        group = TyClGroup { group_ext    = deps                           , group_tyclds = tycl_ds-                          , group_kisigs = kisigs-                          , group_roles  = roles-                          , group_instds = inst_ds }+                          , group_kisigs = getKindSigs node_bndrs kisig_env+                          , group_roles  = getRoleAnnots node_bndrs role_env+                          , group_instds = [] }  -- | Free variables of standalone kind signatures. newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)@@ -1552,32 +1615,39 @@ rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)   = do  { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures         ; unless standalone_ki_sig_ok $ addErr TcRnUnexpectedStandaloneKindSig-        ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v-        ; let doc = StandaloneKindSigCtx (ppr v)-        ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki+        ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) SigLikeStandaloneKindSig v+        ; (new_ki, fvs) <- rnHsSigType (StandaloneKindSigCtx v) KindLevel ki         ; return (StandaloneKindSig noExtField new_v new_ki, fvs)         } +-- See Note [Dependency analysis of type and class decls] depAnalTyClDecls :: GlobalRdrEnv-                 -> KindSig_FV_Env+                 -> NameSet                         -- Names in the current HsGroup+                 -> KindSig_FV_Env                  -- FVs of standalone kind signatures                  -> [(LTyClDecl GhcRn, FreeVars)]-                 -> [SCC (LTyClDecl GhcRn)]--- See Note [Dependency analysis of type, class, and instance decls]-depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs+                 -> [SCC (LTyClDecl GhcRn, NameSet)]+depAnalTyClDecls rdr_env tc_names kisig_fv_env ds_w_fvs   = stronglyConnCompFromEdgedVerticesUniq edges   where-    edges :: [ Node Name (LTyClDecl GhcRn) ]-    edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps))+    -- Build a graph where each node is a `TyClDecl` keyed by its name, and+    -- its `FreeVars` give rise to edges.+    -- Step (TCDEP3) of Note [Dependency analysis of type and class decls]+    edges :: [ Node Name (LTyClDecl GhcRn, NameSet) ]+    edges = [ DigraphNode (d, deps) name (nonDetEltsUniqSet deps)+              -- nonDetEltsUniqSet is OK to use here because the order of the edges+              -- has no effect on the result of stronglyConnCompFromEdgedVerticesUniq.+              -- See Note [Deterministic SCC] in GHC.Data.Graph.Directed.+             | (d, fvs) <- ds_w_fvs,               let { name = tcdName (unLoc d)                   ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name-                  ; deps = fvs `plusFV` kisig_fvs+                  ; node_fvs = fvs `plusFV` kisig_fvs -- (TCDEP3.fvs_kisig)+                  ; deps = toParents rdr_env node_fvs `intersectFVs` tc_names+                      -- (toParents rdr_env) maps datacons to parent tycons (TCDEP3.fvs_parent),+                      -- (`intersectFVs` tc_names) filters out imported names (TCDEP3.fvs_nogbl).+                      -- See also Note [Prepare TyClGroup FVs]                   }             ]-            -- 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.  toParents :: GlobalRdrEnv -> NameSet -> NameSet toParents rdr_env ns@@ -1595,7 +1665,82 @@                     _                        -> n       Nothing -> n +{- Note [Prepare TyClGroup FVs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The renamer returns, alongside each renamed type/class declaration or instance,+the set of its free variables: +  rnTyClDecl    :: TyClDecl GhcPs -> RnM (TyClDecl GhcRn, FreeVars)+  rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)++For example:++  type family F (a :: k)        -- FVs: {}+  data X = MkX Char (Maybe X)   -- FVs: {Char, Maybe, X}+  data Y = MkY X (Maybe Y)      -- FVs: {Maybe, Y, X}+  type instance F MkX = X       -- FVs: {F, MkX, X}+  type instance F MkY = Int     -- FVs: {F, MkY, Int}++This is almost what we need for dependency analysis (i.e. to figure out in which+order to check the declarations), but first we apply a few transformations:++* toParents rdr_env inst_fvs `intersectFVs` tc_names   -- in mkInstGroups+* toParents rdr_env node_fvs `intersectFVs` tc_names   -- in depAnalTyClDecls+* delFVs node_bndrs (plusFVs nodes_deps)               -- in rnTyClGroups++The cited lines of code are somewhat far apart; to see the big picture, refer+to Note [Dependency analysis of type and class decls], and more specifically+steps TCDEP3, TCDEP5, and TCDEP6.++The cumulative effect of these transformations is as follows:++* Data constructor names are replaced by the parent type constructors:+    {MkX} ==> {X}+  Part of the code:+    toParents rdr_env+  Reason:+    MkX does not get its own node in the dependency graph,+    so we cannot make an edge to it in `depAnalTyClDecls`++* Names defined outside the current HsGroup are filtered out:+    {Char,Maybe} ==> {}+  Part of the code:+    `intersectFVs` tc_names+  Reason:+    makes the NameSet smaller, so there are fewer subsequent lookups+    in `graphFromEdgedVertices` (GHC.Data.Graph.Directed)+    and in `isReadyTyClGroup`   (GHC.Tc.TyCl)++* Self-references are removed:+    {A,B,C} ==> {C}, iff in the TyClGroup that defines {A,B}+  Part of the code:+    delFVs node_bndrs+  Reason:+    avoids the problem that `isReadyTyClGroup` would otherwise consider+    a recursive TyClGroup to be blocked on itself+  Note:+    needs to happen after the SCC analysis because of+    mutually-recursive data types++These "prepared" FVs are the lexical dependencies of a TyClGroup that are stored+in the XCTyClGroup extension field:++  type family F (a :: k)        -- XCTyClGroup: {}+  data X = MkX Char (Maybe X)   -- XCTyClGroup: {}+  data Y = MkY X (Maybe Y)      -- XCTyClGroup: {X}+  type instance F MkX = X       -- XCTyClGroup: {F, X}+  type instance F MkY = Int     -- XCTyClGroup: {F, Y}++Before attempting to kind-check a TyClGroup, all of its lexical dependencies+need to be satisfied, i.e. there must be a TyThing in the TypeEnv for each of+these names.++Imported names {Char,Maybe} don't need to be explicitly included in the set of+lexical dependencies because `isReadyTyClGroup` can safely assume those are+definitely already in the env.+-}++ {- ****************************************************** *                                                       *        Role annotations@@ -1621,7 +1766,7 @@       = do {  -- the name is an *occurrence*, but look it up only in the               -- decls defined in this group (see #10263)              tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)-                                          (text "role annotation")+                                          SigLikeRoleAnnotation                                           tycon            ; return $ RoleAnnotDecl noExtField tycon' roles } @@ -1659,43 +1804,27 @@ ****************************************************** -}  ------------------------------------------------------------- | 'InstDeclFreeVarsMap is an association of an---   @InstDecl@ with @FreeVars@. The @FreeVars@ are---   the tycon names that are both---     a) free in the instance declaration---     b) bound by this group of type/class/instance decls-type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]---- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the---   @FreeVars@ which are *not* the binders of a @TyClDecl@.-mkInstDeclFreeVarsMap :: GlobalRdrEnv-                      -> NameSet-                      -> [(LInstDecl GhcRn, FreeVars)]-                      -> InstDeclFreeVarsMap-mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs-  = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)-    | (inst_decl, fvs) <- inst_ds_fvs ]---- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the---   @InstDeclFreeVarsMap@ with these entries removed.--- We call (getInsts tcs instd_map) when we've completed the declarations--- for 'tcs'.  The call returns (inst_decls, instd_map'), where---   inst_decls are the instance declarations all of---              whose free vars are now defined---   instd_map' is the inst-decl map with 'tcs' removed from---               the free-var set-getInsts :: [Name] -> InstDeclFreeVarsMap-         -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)-getInsts bndrs inst_decl_map-  = partitionWith pick_me inst_decl_map+-- | Construct a @TyClGroup@ for each @InstDecl@.+-- Step (TCDEP6) of Note [Dependency analysis of type and class decls]+mkInstGroups :: GlobalRdrEnv+             -> NameSet+             -> [(LInstDecl GhcRn, FreeVars)]+             -> [TyClGroup GhcRn]+mkInstGroups rdr_env tc_names inst_ds_fvs+  = [ mk_inst_group deps inst_decl+    | (inst_decl, inst_fvs) <- inst_ds_fvs+    , let deps = toParents rdr_env inst_fvs `intersectFVs` tc_names ]+            -- (toParents rdr_env) maps datacons to parent tycons,+            -- (`intersectFVs` tc_names) filters out imported names.+            -- See Note [Prepare TyClGroup FVs]   where-    pick_me :: (LInstDecl GhcRn, FreeVars)-            -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)-    pick_me (decl, fvs)-      | isEmptyNameSet depleted_fvs = Left decl-      | otherwise                   = Right (decl, depleted_fvs)-      where-        depleted_fvs = delFVs bndrs fvs+    mk_inst_group :: NameSet -> LInstDecl GhcRn -> TyClGroup GhcRn+    mk_inst_group deps inst_d =+      TyClGroup { group_ext = deps+                , group_tyclds = []+                , group_kisigs = []+                , group_roles  = []+                , group_instds = [inst_d] }  {- ****************************************************** *                                                       *@@ -1714,7 +1843,7 @@  rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,                       tcdFixity = fixity, tcdRhs = rhs })-  = do { tycon' <- lookupLocatedTopConstructorRnN tycon+  = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon        ; let kvs = extractHsTyRdrTyVarsKindVars rhs              doc = TySynCtx tycon        ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)@@ -1734,7 +1863,7 @@     { tcdLName = tycon, tcdTyVars = tyvars,       tcdFixity = fixity,       tcdDataDefn = defn@HsDataDefn{ dd_cons = cons, dd_kindSig = kind_sig} })-  = do { tycon' <- lookupLocatedTopConstructorRnN tycon+  = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon        ; let kvs = extractDataDefnKindVars defn              doc = TyDataCtx tycon              new_or_data = dataDefnConsNewOrData cons@@ -1756,7 +1885,7 @@                         tcdFDs = fds, tcdSigs = sigs,                         tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,                         tcdDocs = docs})-  = do  { lcls' <- lookupLocatedTopConstructorRnN lcls+  = do  { lcls' <- lookupLocatedTopBndrRnN WL_TyCon lcls         ; let cls' = unLoc lcls'               kvs = []  -- No scoped kind vars except those in                         -- kind signatures on the tyvars@@ -1923,19 +2052,17 @@            }      has_labelled_fields (ConDeclGADT { con_g_args = RecConGADT _ _ }) = True-    has_labelled_fields (ConDeclH98 { con_args = RecCon rec })-      = not (null (unLoc rec))+    has_labelled_fields (ConDeclH98 { con_args = RecCon flds })+      = not (null (unLoc flds))     has_labelled_fields _ = False      has_strictness_flags condecl-      = any (is_strict . getBangStrictness . hsScaledThing) (con_args condecl)--    is_strict (HsSrcBang _ (HsBang _ s)) = isSrcStrict s+      = any isSrcStrict (con_arg_bangs condecl) -    con_args (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = args-    con_args (ConDeclH98 { con_args = PrefixCon _ args }) = args-    con_args (ConDeclH98 { con_args = InfixCon arg1 arg2 }) = [arg1, arg2]-    con_args _ = []+    con_arg_bangs (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = map cdf_bang args+    con_arg_bangs (ConDeclH98 { con_args = PrefixCon args }) = map cdf_bang args+    con_arg_bangs (ConDeclH98 { con_args = InfixCon arg1 arg2 }) = [cdf_bang arg1, cdf_bang arg2]+    con_arg_bangs _ = []  {- Note [Type data declarations]@@ -2102,7 +2229,7 @@   from `type data`, which do not use the distinguishing quote mark added   to constructors promoted by DataKinds. -* GHC.Core.TyCon.isDataTyCon ignores types coming from a `type data`+* GHC.Core.TyCon.isBoxedDataTyCon ignores types coming from a `type data`   declaration (by checking the `is_type_data` field), so that these do   not contribute executable code such as constructor wrappers. @@ -2213,7 +2340,7 @@                              , fdFixity = fixity                              , fdInfo = info, fdResultSig = res_sig                              , fdInjectivityAnn = injectivity })-  = do { tycon' <- lookupLocatedTopConstructorRnN tycon+  = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon        ; ((tyvars', res_sig', injectivity'), fv1) <-             bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->             do { let rn_sig = rnFamResultSig doc@@ -2398,7 +2525,7 @@                            , con_mb_cxt = mcxt, con_args = args                            , con_doc = mb_doc, con_forall = forall_ })   = do  { _        <- addLocM checkConName name-        ; new_name <- lookupLocatedTopConstructorRnN name+        ; new_name <- lookupLocatedTopBndrRnN WL_ConLike name          -- We bind no implicit binders here; this is just like         -- a nested HsForAllTy.  E.g. consider@@ -2428,13 +2555,14 @@                   all_fvs) }}  rnConDecl (ConDeclGADT { con_names   = names-                       , con_bndrs   = L l outer_bndrs+                       , con_outer_bndrs = L outer_bndrs_loc outer_bndrs+                       , con_inner_bndrs = inner_bndrs                        , con_mb_cxt  = mcxt                        , con_g_args  = args                        , con_res_ty  = res_ty                        , con_doc     = mb_doc })   = do  { mapM_ (addLocM checkConName) names-        ; new_names <- mapM (lookupLocatedTopConstructorRnN) names+        ; new_names <- mapM (lookupLocatedTopBndrRnN WL_ConLike) names          ; let -- We must ensure that we extract the free tkvs in left-to-right               -- order of their appearance in the constructor type.@@ -2443,6 +2571,7 @@               -- See #14808.               implicit_bndrs =                 extractHsOuterTvBndrs outer_bndrs           $+                extractHsForAllTelescopes inner_bndrs       $                 extractHsTysRdrTyVars (hsConDeclTheta mcxt) $                 extractConDeclGADTDetailsTyVars args        $                 extractHsTysRdrTyVars [res_ty] []@@ -2450,6 +2579,7 @@         ; let ctxt = ConDeclCtx (toList new_names)          ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->+          bindHsForAllTelescopes ctxt inner_bndrs $ \inner_bndrs' ->     do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt         ; (new_args, fvs2)   <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args         ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty@@ -2463,10 +2593,12 @@         ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3          ; traceRn "rnConDecl (ConDeclGADT)"-            (ppr names $$ ppr outer_bndrs')+            (ppr names $$ ppr outer_bndrs' $$ ppr inner_bndrs')         ; new_mb_doc <- traverse rnLHsDoc mb_doc         ; return (ConDeclGADT { con_g_ext = noExtField, con_names = new_names-                              , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt+                              , con_outer_bndrs = L outer_bndrs_loc outer_bndrs'+                              , con_inner_bndrs = inner_bndrs'+                              , con_mb_cxt = new_cxt                               , con_g_args = new_args, con_res_ty = new_res_ty                               , con_doc = new_mb_doc },                   all_fvs) } }@@ -2482,15 +2614,15 @@    -> HsDocContext    -> HsConDeclH98Details GhcPs    -> RnM (HsConDeclH98Details GhcRn, FreeVars)-rnConDeclH98Details _ doc (PrefixCon _ tys)-  = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys-       ; return (PrefixCon noTypeArgs new_tys, fvs) }+rnConDeclH98Details _ doc (PrefixCon tys)+  = do { (new_tys, fvs) <- mapFvRn (rnHsConDeclField doc) tys+       ; return (PrefixCon new_tys, fvs) } rnConDeclH98Details _ doc (InfixCon ty1 ty2)-  = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1-       ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2+  = do { (new_ty1, fvs1) <- rnHsConDeclField doc ty1+       ; (new_ty2, fvs2) <- rnHsConDeclField doc ty2        ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } rnConDeclH98Details con doc (RecCon flds)-  = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds+  = do { (new_flds, fvs) <- rnRecHsConDeclRecFields con doc flds        ; return (RecCon new_flds, fvs) }  rnConDeclGADTDetails ::@@ -2499,20 +2631,20 @@    -> HsConDeclGADTDetails GhcPs    -> RnM (HsConDeclGADTDetails GhcRn, FreeVars) rnConDeclGADTDetails _ doc (PrefixConGADT _ tys)-  = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys+  = do { (new_tys, fvs) <- mapFvRn (rnHsConDeclField doc) tys        ; return (PrefixConGADT noExtField new_tys, fvs) } rnConDeclGADTDetails con doc (RecConGADT _ flds)-  = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds+  = do { (new_flds, fvs) <- rnRecHsConDeclRecFields con doc flds        ; return (RecConGADT noExtField new_flds, fvs) } -rnRecConDeclFields ::+rnRecHsConDeclRecFields ::      Name   -> HsDocContext-  -> LocatedL [LConDeclField GhcPs]-  -> RnM (LocatedL [LConDeclField GhcRn], FreeVars)-rnRecConDeclFields con doc (L l fields)-  = do  { fls <- lookupConstructorFields con-        ; (new_fields, fvs) <- rnConDeclFields doc fls fields+  -> LocatedL [LHsConDeclRecField GhcPs]+  -> RnM (LocatedL [LHsConDeclRecField GhcRn], FreeVars)+rnRecHsConDeclRecFields con doc (L l fields)+  = do  { fls <- lookupConstructorFields (noUserRdr con)+        ; (new_fields, fvs) <- rnHsConDeclRecFields doc fls fields                 -- No need to check for duplicate fields                 -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn         ; pure (L l new_fields, fvs) }@@ -2552,20 +2684,20 @@           bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)           let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as           flds <- mapM (newRecordFieldLabel dup_fields_ok has_sel [bnd_name]) field_occs-          let con_info = mkConInfo ConIsPatSyn (conDetailsArity length (RecCon as)) flds+          let con_info = mkConInfo ConIsPatSyn (conDetailsVisArity (RecCon as)) flds           return ((PatSynName bnd_name, con_info) : names)       | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind       = do         bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)-        let con_info = mkConInfo ConIsPatSyn (conDetailsArity length as) []+        let con_info = mkConInfo ConIsPatSyn (conDetailsVisArity as) []         return ((PatSynName bnd_name, con_info) : names)       | otherwise       = return names -conDetailsArity :: (rec -> Arity) -> HsConDetails tyarg arg rec -> Arity-conDetailsArity recToArity = \case-  PrefixCon _ args -> length args-  RecCon rec -> recToArity rec+conDetailsVisArity :: HsPatSynDetails (GhcPass p) -> VisArity+conDetailsVisArity = \case+  PrefixCon args -> length args+  RecCon flds -> length flds   InfixCon _ _ -> 2  {-@@ -2591,7 +2723,7 @@  rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name) rnHsTyVar (L l tyvar) = do-  tyvar' <- lookupOccRn tyvar+  tyvar' <- lookupOccRn WL_TyVar tyvar   return (L l tyvar')  {-@@ -2688,8 +2820,8 @@ add gp l (DocD _ d) ds   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds -add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]-          -> [TyClGroup (GhcPass p)]+add_tycld :: LTyClDecl GhcPs -> [TyClGroup GhcPs]+          -> [TyClGroup GhcPs] add_tycld d []       = [TyClGroup { group_ext    = noExtField                                   , group_tyclds = [d]                                   , group_kisigs = []@@ -2700,8 +2832,8 @@ add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)   = ds { group_tyclds = d : tyclds } : dss -add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]-          -> [TyClGroup (GhcPass p)]+add_instd :: LInstDecl GhcPs -> [TyClGroup GhcPs]+          -> [TyClGroup GhcPs] add_instd d []       = [TyClGroup { group_ext    = noExtField                                   , group_tyclds = []                                   , group_kisigs = []@@ -2712,8 +2844,8 @@ add_instd d (ds@(TyClGroup { group_instds = instds }):dss)   = ds { group_instds = d : instds } : dss -add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]-               -> [TyClGroup (GhcPass p)]+add_role_annot :: LRoleAnnotDecl GhcPs -> [TyClGroup GhcPs]+               -> [TyClGroup GhcPs] add_role_annot d [] = [TyClGroup { group_ext    = noExtField                                  , group_tyclds = []                                  , group_kisigs = []@@ -2724,8 +2856,8 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)   = tycls { group_roles = d : roles } : rest -add_kisig :: LStandaloneKindSig (GhcPass p)-         -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]+add_kisig :: LStandaloneKindSig GhcPs+         -> [TyClGroup GhcPs] -> [TyClGroup GhcPs] add_kisig d [] = [TyClGroup { group_ext    = noExtField                             , group_tyclds = []                             , group_kisigs = [d]
compiler/GHC/Rename/Names.hs view
@@ -54,7 +54,7 @@ import GHC.Iface.Syntax ( fromIfaceWarnings ) import GHC.Builtin.Names import GHC.Parser.PostProcess ( setRdrNameSpace )-import GHC.Core.Type+import GHC.Core.TyCo.Tidy import GHC.Core.PatSyn import GHC.Core.TyCon ( TyCon, tyConName ) import qualified GHC.LanguageExtensions as LangExt@@ -74,10 +74,9 @@ import GHC.Types.Hint import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc-import GHC.Types.Basic  ( TopLevelFlag(..) )+import GHC.Types.Basic  ( TopLevelFlag(..), TyConFlavour (..), convImportLevel ) import GHC.Types.SourceText import GHC.Types.Id-import GHC.Types.HpcInfo import GHC.Types.PkgQual import GHC.Types.GREInfo (ConInfo(..), ConFieldInfo (..), ConLikeInfo (ConIsData)) @@ -205,21 +204,21 @@ -- Note: Do the non SOURCE ones first, so that we get a helpful warning -- for SOURCE ones that are unnecessary rnImports :: [(LImportDecl GhcPs, SDoc)]-          -> RnM ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+          -> RnM ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails) rnImports imports = do     tcg_env <- getGblEnv     -- NB: want an identity module here, because it's OK for a signature     -- module to import from its implementor     let this_mod = tcg_mod tcg_env     let (source, ordinary) = partition (is_source_import . fst) imports-        is_source_import d = ideclSource (unLoc d) == IsBoot+        is_source_import (d::LImportDecl GhcPs) = ideclSource (unLoc d) == IsBoot     stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary     stuff2 <- mapAndReportM (rnImportDecl this_mod) source     -- Safe Haskell: See Note [Tracking Trust Transitively]-    let (decls, imp_user_spec, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)+    let (decls, imp_user_spec, rdr_env, imp_avails) = combine (stuff1 ++ stuff2)     -- Update imp_boot_mods if imp_direct_mods mentions any of them     let merged_import_avail = clobberSourceImports imp_avails-    return (decls, imp_user_spec, rdr_env, merged_import_avail, hpc_usage)+    return (decls, imp_user_spec, rdr_env, merged_import_avail)    where     clobberSourceImports imp_avails =@@ -229,25 +228,24 @@                             (imp_boot_mods imp_avails)                             (imp_direct_dep_mods imp_avails) -        combJ (GWIB _ IsBoot) x = Just x-        combJ r _               = Just r+        combJ (GWIB _ IsBoot) (_, x) = Just x+        combJ r _                    = Just r     -- See Note [Combining ImportAvails]-    combine :: [(LImportDecl GhcRn,  ImportUserSpec, GlobalRdrEnv, ImportAvails, AnyHpcUsage)]-            -> ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+    combine :: [(LImportDecl GhcRn,  ImportUserSpec, GlobalRdrEnv, ImportAvails)]+            -> ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails)     combine ss =-      let (decls, imp_user_spec, rdr_env, imp_avails, hpc_usage, finsts) = foldr+      let (decls, imp_user_spec, rdr_env, imp_avails, finsts) = foldr             plus-            ([], [], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)+            ([], [], emptyGlobalRdrEnv, emptyImportAvails, emptyModuleSet)             ss-      in (decls, imp_user_spec, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }, hpc_usage)+      in (decls, imp_user_spec, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }) -    plus (decl,  us, gbl_env1, imp_avails1, hpc_usage1)-         (decls, uss, gbl_env2, imp_avails2, hpc_usage2, finsts_set)+    plus (decl,  us, gbl_env1, imp_avails1)+         (decls, uss, gbl_env2, imp_avails2, finsts_set)       = ( decl:decls,           us:uss,           gbl_env1 `plusGlobalRdrEnv` gbl_env2,           imp_avails1' `plusImportAvails` imp_avails2,-          hpc_usage1 || hpc_usage2,           extendModuleSetList finsts_set new_finsts )       where       imp_avails1' = imp_avails1 { imp_finsts = [] }@@ -311,11 +309,13 @@ --  4. A boolean 'AnyHpcUsage' which is true if the imported module --     used HPC. rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc)-             -> RnM (LImportDecl GhcRn, ImportUserSpec , GlobalRdrEnv, ImportAvails, AnyHpcUsage)+             -> RnM (LImportDecl GhcRn, ImportUserSpec , GlobalRdrEnv, ImportAvails) rnImportDecl this_mod              (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name                                      , ideclPkgQual = raw_pkg_qual-                                     , ideclSource = want_boot, ideclSafe = mod_safe+                                     , ideclSource = want_boot+                                     , ideclSafe = mod_safe+                                     , ideclLevelSpec = import_level                                      , ideclQualified = qual_style                                      , ideclExt = XImportDeclPass { ideclImplicit = implicit }                                      , ideclAs = as_mod, ideclImportList = imp_details }), import_reason)@@ -393,7 +393,8 @@         qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name         imp_spec  = ImpDeclSpec { is_mod = imp_mod, is_qual = qual_only,                                   is_dloc = locA loc, is_as = qual_mod_name,-                                  is_pkg_qual = pkg_qual, is_isboot = want_boot }+                                  is_pkg_qual = pkg_qual, is_isboot = want_boot,+                                  is_level = convImportLevel import_level }      -- filter the imports according to the import declaration     (new_imp_details, imp_user_list, gbl_env) <- filterImports hsc_env iface imp_spec imp_details@@ -420,6 +421,7 @@             , imv_is_hiding   = is_hiding             , imv_all_exports = potential_gres             , imv_qualified   = qual_only+            , imv_is_level   = convImportLevel import_level             }         imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv) @@ -437,9 +439,10 @@           , ideclQualified = ideclQualified decl           , ideclAs        = ideclAs decl           , ideclImportList = new_imp_details+          , ideclLevelSpec  = ideclLevelSpec decl           } -    return (L loc new_imp_decl, ImpUserSpec imp_spec imp_user_list, gbl_env, imports, mi_hpc iface)+    return (L loc new_imp_decl, ImpUserSpec imp_spec imp_user_list, gbl_env, imports)   -- | Rename raw package imports@@ -460,7 +463,7 @@     | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names     -> ThisPkg uid -    | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)+    | Just uid <- resolvePackageImport unit_state mn (PackageName pkg_fs)     -> OtherPkg uid      | otherwise@@ -470,10 +473,10 @@   where     home_names  = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps -    units = ue_units unit_env+    unit_state = ue_homeUnitState unit_env      hpt_deps :: [UnitId]-    hpt_deps  = homeUnitDepends units+    hpt_deps  = homeUnitDepends unit_state   -- | Calculate the 'ImportAvails' induced by an import of a particular@@ -488,8 +491,8 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by =   let imp_mod    = mi_module iface       imp_sem_mod= mi_semantic_module iface-      orph_iface = mi_orphan (mi_final_exts iface)-      has_finsts = mi_finsts (mi_final_exts iface)+      orph_iface = mi_orphan iface+      has_finsts = mi_finsts iface       deps       = mi_deps iface       trust      = getSafeMode $ mi_trust iface       trust_pkg  = mi_trust_pkg iface@@ -549,14 +552,20 @@        dependent_pkgs = if toUnitId pkg `S.member` other_home_units                         then S.empty-                        else S.singleton ipkg+                        else S.singleton (lvl, ipkg) -      direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units-                      then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot))-                      else S.empty+      lvl = case imported_by of+              ImportedByUser imv -> imv_is_level imv+              ImportedBySystem -> NormalLevel ++      direct_mods = if toUnitId pkg `S.member` other_home_units+                      then mkPlusModDeps (moduleUnitId imp_mod) lvl (GWIB (moduleName imp_mod) want_boot)+                      else emptyInstalledModuleEnv+       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 = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot)@@ -592,6 +601,9 @@           imp_trust_own_pkg = pkg_trust_req      } +mkPlusModDeps :: UnitId -> ImportLevel -> ModuleNameWithIsBoot+          -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot)+mkPlusModDeps uid st elt = extendInstalledModuleEnv emptyInstalledModuleEnv (mkModule uid (gwib_mod elt)) (S.singleton st, elt)  {- ************************************************************************@@ -623,7 +635,7 @@     See Note [GlobalRdrEnv shadowing]  3. We find out whether we are inside a [d| ... |] by testing the TH-   stage. This is a slight hack, because the stage field was really+   level. This is a slight hack, because the level field was really    meant for the type checker, and here we are not interested in the    fields of Brack, hence the error thunks in thRnBrack. -}@@ -639,18 +651,18 @@ extendGlobalRdrEnvRn new_gres new_fixities   = checkNoErrs $  -- See Note [Fail fast on duplicate definitions]     do  { (gbl_env, lcl_env) <- getEnvs-        ; stage <- getStage+        ; level <- getThLevel         ; isGHCi <- getIsGHCi         ; let rdr_env  = tcg_rdr_env gbl_env               fix_env  = tcg_fix_env gbl_env               th_bndrs = getLclEnvThBndrs lcl_env-              th_lvl   = thLevel stage+              th_lvl   = thLevelIndex level                -- Delete new_occs from global and local envs               -- If we are in a TemplateHaskell decl bracket,               --    we are going to shadow them               -- See Note [GlobalRdrEnv shadowing]-              inBracket = isBrackStage stage+              inBracket = isBrackLevel level                lcl_env_TH = modifyLclCtxt (\lcl_env -> lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_gres_env }) lcl_env                            -- See Note [GlobalRdrEnv shadowing]@@ -1189,8 +1201,10 @@              (gres, imp_user_list) = case want_hiding of               Exactly ->-                let gre_env = mkGlobalRdrEnv $ concatMap (gresFromIE decl_spec) items2-                in (gre_env, ImpUserExplicit gre_env)+                let gres = concatMap (gresFromIE decl_spec) items2+                    gre_env = mkGlobalRdrEnv gres+                    implicit_parents = mkNameSet $ mapMaybe parentOfImplicitlyImportedGRE gres+                in (gre_env, ImpUserExplicit (gresToAvailInfo $ globalRdrEnvElts $ gre_env) implicit_parents)               EverythingBut ->                 let hidden_names = mkNameSet $ concatMap (map greName . snd) items2                 in (importsFromIface hsc_env iface decl_spec (Just hidden_names), ImpUserEverythingBut hidden_names)@@ -1241,8 +1255,7 @@     lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, [GlobalRdrElt])]     lookup_lie (L loc ieRdr)         = setSrcSpanA loc $-          do (stuff, warns) <- liftM (fromMaybe ([],[])) $-                               run_lookup (lookup_ie ieRdr)+          do (stuff, warns) <- run_lookup ([],[]) (lookup_ie ieRdr)              mapM_ (addTcRnDiagnostic <=< warning_msg) warns              return [ (L loc ie, gres) | (ie,gres) <- stuff ]         where@@ -1252,11 +1265,10 @@               pure (TcRnDodgyImports (DodgyImportsEmptyParent n))             warning_msg MissingImportList =               pure (TcRnMissingImportList ieRdr)-            warning_msg (BadImportW ie) = do-              -- 'BadImportW' is only constructed below in 'handle_bad_import', in-              -- the 'EverythingBut' case, so that's what we pass to-              -- 'badImportItemErr'.-              reason <- badImportItemErr iface decl_spec ie IsNotSubordinate all_avails+            warning_msg (BadImportW ie sub) = do+              -- 'BadImportW' is only constructed below in 'bad_import_w', in+              -- the 'EverythingBut' case, so here we assume a 'hiding' clause.+              (reason :| _) <- badImportItemErr iface decl_spec ie sub all_avails               pure (TcRnDodgyImports (DodgyImportsHiding reason))             warning_msg (DeprecatedExport n w) =               pure $ TcRnPragmaWarning@@ -1265,18 +1277,18 @@                            , pwarn_impmod  = moduleName import_mod }                          w -            run_lookup :: IELookupM a -> TcRn (Maybe a)-            run_lookup m = case m of+            run_lookup :: a -> IELookupM a -> TcRn a+            run_lookup def m = case m of               Failed err -> do-                msg <- lookup_err_msg err-                addErr (TcRnImportLookup msg)-                return Nothing-              Succeeded a -> return (Just a)+                msgs <- lookup_err_msgs err+                forM_ msgs $ \msg -> addErr (TcRnImportLookup msg)+                return def+              Succeeded a -> return a -            lookup_err_msg err = case err of+            lookup_err_msgs err = case err of               BadImport ie sub    -> badImportItemErr iface decl_spec ie sub all_avails-              IllegalImport       -> pure ImportLookupIllegal-              QualImportError rdr -> pure (ImportLookupQualified rdr)+              IllegalImport       -> pure $ NE.singleton ImportLookupIllegal+              QualImportError rdr -> pure $ NE.singleton (ImportLookupQualified rdr)          -- For each import item, we convert its RdrNames to Names,         -- and at the same time compute all the GlobalRdrElt corresponding@@ -1360,26 +1372,28 @@             -- Look up the children in the sub-names of the parent            -- See Note [Importing DuplicateRecordFields]-           case lookupChildren subnames rdr_ns of--             Failed rdrs -> failLookupWith $-                            BadImport (IEThingWith (deprecation, ann) ltc wc rdrs noDocstring) IsSubordinate-                                -- We are trying to import T( a,b,c,d ), and failed-                                -- to find 'b' and 'd'.  So we make up an import item-                                -- to report as failing, namely T( b, d ).-                                -- c.f. #15412+           let (children_errs, childnames) = lookupChildren subnames rdr_ns -             Succeeded childnames ->-                return ([ (IEThingWith (Nothing, ann) (L l name') wc childnames' noDocstring-                          ,gres)]-                       , export_depr_warns)+           bad_import_warns <-+             if null children_errs then return [] else+             let items = map lce_wrapped_name children_errs+                 ie    = IEThingWith (deprecation, ann) ltc wc items noDocstring+                         -- We are trying to import T( a,b,c,d ), and failed+                         -- to find 'b' and 'd'.  So we make up an import item+                         -- to report as failing, namely T( b, d ).+                         -- c.f. #15413+                 subordinate_err = mkSubordinateError gre children_errs+             in bad_import_w ie subordinate_err -              where name' = replaceWrappedName rdr_tc name-                    childnames' = map (to_ie_post_rn . fmap greName) childnames-                    gres = gre : map unLoc childnames-                    export_depr_warns-                      | want_hiding == Exactly = mapMaybe mk_depr_export_warning gres-                      | otherwise              = []+           let name' = replaceWrappedName rdr_tc name+               childnames' = map (to_ie_post_rn . fmap greName) childnames+               gres = gre : map unLoc childnames+               export_depr_warns+                 | want_hiding == Exactly = mapMaybe mk_depr_export_warning gres+                 | otherwise              = []+           return ([ (IEThingWith (Nothing, ann) (L l name') wc childnames' noDocstring+                     ,gres)]+                  , bad_import_warns ++ export_depr_warns)          _other -> failLookupWith IllegalImport         -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed...@@ -1393,32 +1407,59 @@         -- N.B. imports never have docstrings         noDocstring = Nothing -        handle_bad_import m = catchIELookup m $ \err -> case err of-          BadImport ie _-            | want_hiding == EverythingBut-            -> return ([], [BadImportW ie])-          _ -> failLookupWith err+        handle_bad_import m = catchIELookup m $ \case+          BadImport ie sub -> do+            ws <- bad_import_w ie sub+            return ([], ws)+          err -> failLookupWith err +        bad_import_w :: IE GhcPs -> IsSubordinateError -> IELookupM [IELookupWarning]+        bad_import_w ie sub+          | want_hiding == EverythingBut = return [BadImportW ie sub]+          | otherwise = failLookupWith (BadImport ie sub)+         mk_depr_export_warning gre-          = DeprecatedExport name <$> mi_export_warn_fn (mi_final_exts iface) name+          = DeprecatedExport name <$> mi_export_warn_fn iface name           where             name = greName gre  type IELookupM = MaybeErr IELookupError  data IELookupWarning-  = BadImportW (IE GhcPs)+  = BadImportW (IE GhcPs) IsSubordinateError   | MissingImportList   | DodgyImport GlobalRdrElt   | DeprecatedExport Name (WarningTxt GhcRn)  -- | Is this import/export item a subordinate or not?-data IsSubordinate-  = IsSubordinate | IsNotSubordinate+data IsSubordinateError+  = IsSubordinateError { subordinate_err_parent      :: !GlobalRdrElt+                       , subordinate_err_unavailable :: [FastString]+                       , subordinate_err_nontype     :: [GlobalRdrElt]+                       , subordinate_err_nondata     :: [GlobalRdrElt] }+  | IsNotSubordinate +mkSubordinateError :: GlobalRdrElt -> [LookupChildError] -> IsSubordinateError+mkSubordinateError gre children_errs = foldr add init_acc children_errs+  where+    init_acc :: IsSubordinateError+    init_acc = IsSubordinateError gre [] [] []++    add :: LookupChildError -> IsSubordinateError -> IsSubordinateError+    add children_err sub@IsSubordinateError{} =+      case children_err of+        LookupChildNonType{lce_nontype_item = g} ->+          sub { subordinate_err_nontype = g : subordinate_err_nontype sub }+        LookupChildNonData{lce_nondata_item = g} ->+          sub { subordinate_err_nondata = g : subordinate_err_nondata sub }+        LookupChildNotFound (L _ wname) ->+          let fs = (occNameFS . rdrNameOcc . ieWrappedName) wname+          in sub { subordinate_err_unavailable = fs : subordinate_err_unavailable sub }+    add _ IsNotSubordinate = panic "mkSubordinateError: IsNotSubordinate"+ data IELookupError   = QualImportError RdrName-  | BadImport (IE GhcPs) IsSubordinate+  | BadImport (IE GhcPs) IsSubordinateError   | IllegalImport  failLookupWith :: IELookupError -> IELookupM a@@ -1559,9 +1600,25 @@     set_gre_imp gre@( GRE { gre_name = nm } )       = gre { gre_imp = unitBag $ prov_fn nm } -{--Note [Children for duplicate record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+parentOfImplicitlyImportedGRE :: Outputable info => GlobalRdrEltX info -> Maybe Name+parentOfImplicitlyImportedGRE gre =+  if any (explicit_import . is_item) $ gre_imp gre+  then Nothing+  else+    case greParent gre of+      NoParent ->+        pprPanic "parentOfImplicitlyImportedGRE" $+           (text "implicitly imported GRE with no parent" <+> ppr gre)+      ParentIs par ->+        Just par+  where+    explicit_import :: ImpItemSpec -> Bool+    explicit_import (ImpAll {}) =+      pprPanic "parentOfImplicitlyImportedGRE: ImpAll" (ppr gre)+    explicit_import (ImpSome { is_explicit }) = is_explicit++{- Note [Children for duplicate record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the module      {-# LANGUAGE DuplicateRecordFields #-}@@ -1585,45 +1642,103 @@ findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] +data LookupChildError+  = LookupChildNotFound { lce_wrapped_name :: !(LIEWrappedName GhcPs) }+  | LookupChildNonType  { lce_wrapped_name :: !(LIEWrappedName GhcPs)+                        , lce_nontype_item :: !GlobalRdrElt }+  | LookupChildNonData  { lce_wrapped_name :: !(LIEWrappedName GhcPs)+                        , lce_nondata_item :: !GlobalRdrElt }+ lookupChildren :: [GlobalRdrElt]                -> [LIEWrappedName GhcPs]-               -> MaybeErr [LIEWrappedName GhcPs]   -- The ones for which the lookup failed-                           [LocatedA GlobalRdrElt]+               -> ( [LookupChildError]   -- The ones for which the lookup failed+                  , [LocatedA GlobalRdrElt] ) -- (lookupChildren all_kids rdr_items) maps each rdr_item to its--- corresponding Name all_kids, if the former exists+-- corresponding Name in all_kids, if the former exists -- The matching is done by FastString, not OccName, so that --    Cls( meth, AssocTy ) -- will correctly find AssocTy among the all_kids of Cls, even though -- the RdrName for AssocTy may have a (bogus) DataName namespace -- (Really the rdr_items should be FastStrings in the first place.)-lookupChildren all_kids rdr_items-  | null fails-  = Succeeded (concat oks)-       -- This 'fmap concat' trickily applies concat to the /second/ component-       -- of the pair, whose type is ([LocatedA Name], [[Located FieldLabel]])-  | otherwise-  = Failed fails+lookupChildren all_kids rdr_items = (fails, successes)   where-    mb_xs = map doOne rdr_items-    fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]-    oks   = [ ok      | Succeeded ok   <- mb_xs ]-    oks :: [[LocatedA GlobalRdrElt]]+    mb_xs     = map do_one rdr_items+    fails     = [ err | Failed err    <- mb_xs ]+    successes = [ ok  | Succeeded oks <- mb_xs, ok <- NE.toList oks ] -    doOne item@(L l r)-       = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of-           Just [g]-             | not $ isRecFldGRE g-             -> Succeeded [L l g]-           Just gs-             | all isRecFldGRE gs-             -> Succeeded $ map (L l) gs-           _ -> Failed    item+    do_one :: LIEWrappedName GhcPs -> MaybeErr LookupChildError (NonEmpty (LocatedA GlobalRdrElt))+    do_one item@(L l r) =+      case r of+        IEName{}+          -- IEName (unadorned name) places no restriction on the namespace of+          -- the imported entity, so we look in both `val_gres` and `typ_gres`.+          -- In case of conflict (punning), the value namespace takes priority.+          -- See Note [Prioritise the value namespace in subordinate import lists]+          | (gre:gres) <- val_gres -> Succeeded $ fmap (L l) (gre:|gres)+          | (gre:gres) <- typ_gres -> Succeeded $ fmap (L l) (gre:|gres)+          | otherwise              -> Failed $ LookupChildNotFound item +        IEType{}+          -- IEType ('type' namespace specifier) restricts the lookup to the+          -- type namespace, i.e. to `typ_gres`. In case of failure, we check+          -- `val_gres` to produce a more helpful error message.+          | (gre:gres) <- typ_gres -> Succeeded $ fmap (L l) (gre:|gres)+          | (gre:_)    <- val_gres -> Failed $ LookupChildNonType item gre+          | otherwise              -> Failed $ LookupChildNotFound item++        IEData{}+          -- IEData ('data' namespace specifier) restricts the lookup to the+          -- data namespace, i.e. to `val_gres`. In case of failure, we check+          -- `typ_gres` to produce a more helpful error message.+          | (gre:gres) <- val_gres -> Succeeded $ fmap (L l) (gre:|gres)+          | (gre:_)    <- typ_gres -> Failed $ LookupChildNonData item gre+          | otherwise              -> Failed $ LookupChildNotFound item++        IEPattern{} -> panic "lookupChildren: IEPattern"  -- Never happens (invalid syntax)+        IEDefault{} -> panic "lookupChildren: IEDefault"  -- Never happens (invalid syntax)+      where+        fs = (occNameFS . rdrNameOcc . ieWrappedName) r+        gres = fromMaybe [] (lookupFsEnv kid_env fs)+        (val_gres, typ_gres) = partition (isValNameSpace . greNameSpace) gres+     -- See Note [Children for duplicate record fields]+    kid_env :: FastStringEnv [GlobalRdrElt]     kid_env = extendFsEnvList_C (++) emptyFsEnv               [(occNameFS (occName x), [x]) | x <- all_kids]  +{- Note [Prioritise the value namespace in subordinate import lists]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this program that defines a class that has both an associated type+named (#) and a method named (#)++  module M_assoc where+    class C a b where+      type a # b+      (#) :: a -> b -> ()+  module N_assoc where+    import M_assoc( C((#)) )++In the import declaration, when we see the unadorned name (#) in the subordinate+import list of C, which children should we bring into scope? Our options are:++  a) only the method (#)+  b) only the associated type (#)+  c) both the method and the associated type++To follow the precedent established by top-level items, we go with option (a).+Indeed, consider a slightly different program++  module M_top where+    type family a # b+    a # b = ()+  module N_top where+    import M_top( (#) )++Here the import brings only the function (#) into scope, and one has to say+`type (#)` to get the type family.+-}+ -------------------------------  {-@@ -2122,7 +2237,7 @@     -- to say "T(A,B,C)".  So we have to find out what the module exports.     to_ie rdr_env _ (Avail c)  -- Note [Overloaded field import]       = do { let-               gre = expectJust "getMinimalImports Avail" $ lookupGRE_Name rdr_env c+               gre = expectJust $ lookupGRE_Name rdr_env c            ; return $ [IEVar Nothing (to_ie_post_rn $ noLocA $ greName gre) Nothing] }     to_ie _ _ avail@(AvailTC n [_])  -- Exporting the main decl and nothing else       | availExportsDecl avail@@ -2136,13 +2251,13 @@           | all_used xs           -> return [IEThingAll (Nothing, noAnn) (to_ie_post_rn $ noLocA n) Nothing]           | otherwise-          -> do { let ns_gres = map (expectJust "getMinimalImports AvailTC" . lookupGRE_Name rdr_env) cs+          -> do { let ns_gres = map (expectJust . lookupGRE_Name rdr_env) cs                       ns = map greName ns_gres                 ; return [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard                                  (map (to_ie_post_rn . noLocA) (filter (/= n) ns)) Nothing] }                                        -- Note [Overloaded field import]         _other-          -> do { let infos = map (expectJust "getMinimalImports AvailTC" . lookupGRE_Name rdr_env) cs+          -> do { let infos = map (expectJust . lookupGRE_Name rdr_env) cs                       (ns_gres,fs_gres) = classifyGREs infos                       ns = map greName (ns_gres ++ fs_gres)                       fs = map fieldGREInfo fs_gres@@ -2279,29 +2394,46 @@ -}  badImportItemErr-  :: ModIface -> ImpDeclSpec -> IE GhcPs -> IsSubordinate+  :: ModIface -> ImpDeclSpec -> IE GhcPs+  -> IsSubordinateError   -> [AvailInfo]-  -> TcRn ImportLookupReason+  -> TcRn (NonEmpty ImportLookupReason) badImportItemErr iface decl_spec ie sub avails = do-  patsyns_enabled <- xoptM LangExt.PatternSynonyms-  expl_ns_enabled <- xoptM LangExt.ExplicitNamespaces+  exts <- importLookupExtensions+  let import_lookup_bad :: BadImportKind -> ImportLookupReason+      import_lookup_bad k = ImportLookupBad k iface decl_spec ie exts   dflags <- getDynFlags   hsc_env <- getTopEnv   let rdr_env = mkGlobalRdrEnv               $ gresFromAvails hsc_env (Just imp_spec) all_avails-  pure (ImportLookupBad (importErrorKind dflags rdr_env expl_ns_enabled) iface decl_spec ie patsyns_enabled)+  pure $ fmap import_lookup_bad (importErrorKind dflags rdr_env)   where-    importErrorKind dflags rdr_env expl_ns_enabled+    importErrorKind :: DynFlags -> GlobalRdrEnv -> NonEmpty BadImportKind+    importErrorKind dflags rdr_env       | any checkIfTyCon avails = case sub of-          IsNotSubordinate -> BadImportAvailTyCon expl_ns_enabled-          IsSubordinate -> BadImportNotExportedSubordinates unavailableChildren-      | any checkIfVarName avails = BadImportAvailVar-      | Just con <- find checkIfDataCon avails = BadImportAvailDataCon (availOccName con)-      | otherwise = BadImportNotExported suggs+          IsNotSubordinate -> NE.singleton BadImportAvailTyCon+          IsSubordinateError { subordinate_err_parent = gre+                             , subordinate_err_unavailable = unavailable+                             , subordinate_err_nontype = nontype+                             , subordinate_err_nondata = nondata }+            -> NE.fromList $ catMaybes $+                [ fmap (BadImportNotExportedSubordinates gre) (NE.nonEmpty unavailable)+                , fmap (BadImportNonTypeSubordinates gre) (NE.nonEmpty nontype)+                , fmap (BadImportNonDataSubordinates gre) (NE.nonEmpty nondata) ]+      | any checkIfVarName avails = NE.singleton BadImportAvailVar+      | Just con <- find checkIfDataCon avails = NE.singleton (BadImportAvailDataCon (availOccName con))+      | otherwise = NE.singleton (BadImportNotExported suggs)         where           suggs = similar_suggs ++ fieldSelectorSuggestions rdr_env rdr+          what_look = case sub of+            IsNotSubordinate -> WL_TyCon_or_TermVar+            IsSubordinateError { subordinate_err_parent = gre } ->+              case greInfo gre of+                IAmTyCon ClassFlavour+                  -> WL_TyCon_or_TermVar+                _ -> WL_Term           similar_names =-            similarNameSuggestions (Unbound.LF WL_Anything WL_Global)+            similarNameSuggestions (Unbound.LF what_look WL_Global)               dflags rdr_env emptyLocalRdrEnv rdr           similar_suggs =             case NE.nonEmpty $ mapMaybe imported_item $ similar_names of@@ -2334,9 +2466,12 @@     importedFS = occNameFS $ rdrNameOcc rdr     imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }     all_avails = mi_exports iface-    unavailableChildren = case ie of-      IEThingWith _ _ _ ns _ -> map (rdrNameOcc . ieWrappedName  . unLoc) ns-      _ -> panic "importedChildren failed pattern match: no children"++importLookupExtensions :: TcRn ImportLookupExtensions+importLookupExtensions = do+  ile_pattern_synonyms    <- xoptM LangExt.PatternSynonyms+  ile_explicit_namespaces <- xoptM LangExt.ExplicitNamespaces+  return ImportLookupExtensions{ile_pattern_synonyms, ile_explicit_namespaces}  addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn () addDupDeclErr gres@(gre :| _)
compiler/GHC/Rename/Pat.hs view
@@ -53,6 +53,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType ( hsOverLitName )+import GHC.Rename.Doc (rnLHsDoc) import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils    ( newLocalBndrRn, bindLocalNames@@ -63,17 +64,19 @@ import GHC.Rename.HsType import GHC.Builtin.Names +import GHC.Types.Hint+import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Unique.Set- import GHC.Types.Basic import GHC.Types.SourceText-import GHC.Utils.Misc+ import GHC.Data.FastString ( uniqCompareFS ) import GHC.Data.List.SetOps( removeDups )-import GHC.Utils.Outputable++import GHC.Utils.Misc import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Literal   ( inCharRange )@@ -88,15 +91,11 @@ import Data.Function       ( on ) import Data.Functor.Identity ( Identity (..) ) import qualified Data.List.NonEmpty as NE-import Data.Maybe import Data.Ratio import Control.Monad.Trans.Writer.CPS import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Functor ((<&>))-import GHC.Rename.Doc (rnLHsDoc)-import GHC.Types.Hint-import GHC.Types.Fixity (LexicalFixity(..)) import Data.Coerce  {-@@ -161,11 +160,12 @@                  unCpsRn (fn a) $ \v ->                  k (L loc v)) -lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name)-lookupConCps con_rdr-  = CpsRn (\k -> do { con_name <- lookupLocatedOccRnConstr con_rdr-                    ; (r, fvs) <- k con_name-                    ; return (r, addOneFV fvs (unLoc con_name)) })+lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN (WithUserRdr Name))+lookupConCps lcon_rdr@(L _ con_rdr)+  = CpsRn $ \k ->+    do { con_name <- lookupLocatedOccRnConstr lcon_rdr+       ; (r, fvs) <- k (fmap (WithUserRdr con_rdr) con_name)+       ; return (r, addOneFV fvs (unLoc con_name)) }     -- We add the constructor name to the free vars     -- See Note [Patterns are uses] @@ -447,13 +447,12 @@     --     -- See Note [Don't report shadowing for pattern synonyms]     let bndrs = collectPatsBinders CollVarTyVarBinders (toList pats')-    addErrCtxt doc_pat $+    addErrCtxt (MatchCtxt ctxt) $       if isPatSynCtxt ctxt          then checkDupNames bndrs          else checkDupAndShadowedNames envs_before bndrs     thing_inside pats'   where-    doc_pat = text "In" <+> pprMatchContext ctxt      -- See Note [Invisible binders in functions] in GHC.Hs.Pat     --@@ -510,9 +509,9 @@ rnLArgPatAndThen mk = wrapSrcSpanCps rnArgPatAndThen where    rnArgPatAndThen (InvisPat (_, spec) tp) = do-    liftCps $ unlessXOptM LangExt.TypeAbstractions $-      addErr (TcRnIllegalInvisibleTypePattern tp)     tp' <- rnHsTyPat HsTypePatCtx tp+    liftCps $ unlessXOptM LangExt.TypeAbstractions $+      addErr (TcRnIllegalInvisibleTypePattern tp' InvisPatWithoutFlag)     pure (InvisPat spec tp')   rnArgPatAndThen p = rnPatAndThen mk p @@ -526,6 +525,9 @@ {-# SPECIALISE rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] #-} {-# SPECIALISE rnLPatsAndThen :: NameMaker -> NE.NonEmpty (LPat GhcPs) -> CpsRn (NE.NonEmpty (LPat GhcRn)) #-} +rnLArgPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]+rnLArgPatsAndThen mk = traverse (rnLArgPatAndThen mk)+ -------------------- -- The workhorse rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)@@ -680,10 +682,10 @@   = do { tp' <- rnHsTyPat HsTypePatCtx tp        ; return (EmbTyPat noExtField tp') } rnPatAndThen _ (InvisPat (_, spec) tp)-  = do { liftCps $ addErr (TcRnMisplacedInvisPat tp)-         -- Invisible patterns are handled in `rnLArgPatAndThen`+  = do { -- Invisible patterns are handled in `rnLArgPatAndThen`          -- so unconditionally emit error here        ; tp' <- rnHsTyPat HsTypePatCtx tp+       ; liftCps $ addErr (TcRnIllegalInvisibleTypePattern tp' InvisPatMisplaced)        ; return (InvisPat spec tp')        } @@ -693,39 +695,21 @@                 -> HsConPatDetails GhcPs                 -> CpsRn (Pat GhcRn) -rnConPatAndThen mk con (PrefixCon tyargs pats)+rnConPatAndThen mk con (PrefixCon pats)   = do  { con' <- lookupConCps con-        ; liftCps check_lang_exts-        ; tyargs' <- mapM rnConPatTyArg tyargs-        ; pats' <- rnLPatsAndThen mk pats+        ; pats' <- rnLArgPatsAndThen mk pats         ; return $ ConPat             { pat_con_ext = noExtField             , pat_con = con'-            , pat_args = PrefixCon tyargs' pats'+            , pat_args = PrefixCon pats'             }         }-  where-    check_lang_exts :: RnM ()-    check_lang_exts =-      for_ (listToMaybe tyargs) $ \ arg ->-        do { type_abs   <- xoptM LangExt.TypeAbstractions-           ; type_app   <- xoptM LangExt.TypeApplications-           ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables-           -- See Note [Deprecated type abstractions in constructor patterns]-           ; if | type_abs -> return ()-                | type_app && scoped_tvs -> addDiagnostic TcRnDeprecatedInvisTyArgInConPat-                | otherwise -> addErrTc $ TcRnTypeApplicationsDisabled (TypeApplicationInPattern arg)-           } -    rnConPatTyArg (HsConPatTyArg _ t) = do-      t' <- rnHsTyPat HsTypePatCtx t-      return (HsConPatTyArg noExtField t')- rnConPatAndThen mk con (InfixCon pat1 pat2)   = do  { con' <- lookupConCps con         ; pat1' <- rnLPatAndThen mk pat1         ; pat2' <- rnLPatAndThen mk pat2-        ; fixity <- liftCps $ lookupFixityRn (unLoc con')+        ; fixity <- liftCps $ lookupFixityRn (getName con')         ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }  rnConPatAndThen mk con (RecCon rpats)@@ -733,34 +717,10 @@         ; rpats' <- rnHsRecPatsAndThen mk con' rpats         ; return $ ConPat             { pat_con_ext = noExtField-            , pat_con = con'-            , pat_args = RecCon rpats'+            , pat_con     = con'+            , pat_args    = RecCon rpats'             }         }--{- Note [Deprecated type abstractions in constructor patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Type abstractions in constructor patterns allow the user to bind-existential type variables:--    import Type.Reflection (Typeable, typeRep)-    data Ex = forall e. (Typeable e, Show e) => MkEx e-    showEx (MkEx @e a) = show a ++ " :: " ++ show (typeRep @e)--Note the pattern `MkEx @e a`, and specifically the `@e` binder.--For historical reasons, using this feature only required TypeApplications-and ScopedTypeVariables to be enabled. As per GHC Proposal #448 (and especially-its amendment #604) we are now transitioning towards guarding this feature-behind TypeAbstractions instead.--As a compatibility measure, we continue to support old programs that use-TypeApplications with ScopedTypeVariables instead of TypeAbstractions,-but emit the appropriate compatibility warning, -Wdeprecated-type-abstractions.-This warning is scheduled to become an error in GHC 9.14, at which point-we can simply require TypeAbstractions.--}- checkUnusedRecordWildcardCps :: SrcSpan                              -> Maybe [ImplicitFieldBinders]                              -> CpsRn ()@@ -772,7 +732,7 @@  -------------------- rnHsRecPatsAndThen :: NameMaker-                   -> LocatedN Name      -- Constructor+                   -> LocatedN (WithUserRdr Name) -- constructor                    -> HsRecFields GhcPs (LPat GhcPs)                    -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) rnHsRecPatsAndThen mk (L _ con)@@ -827,8 +787,8 @@ -}  data HsRecFieldContext-  = HsRecFieldCon Name-  | HsRecFieldPat Name+  = HsRecFieldCon (WithUserRdr Name)+  | HsRecFieldPat (WithUserRdr Name)   | HsRecFieldUpd  rnHsRecFields@@ -863,7 +823,9 @@                 HsRecFieldPat con  -> Just con                 HsRecFieldUpd      -> Nothing -    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg)+    rn_fld :: Bool+           -> Maybe (WithUserRdr Name)+           -> LHsRecField GhcPs (LocatedA arg)            -> RnM (LHsRecField GhcRn (LocatedA arg))     rn_fld pun_ok parent (L l                            (HsFieldBind@@ -887,11 +849,11 @@                  , hfbPun = pun } }      rn_dotdot :: Maybe (LocatedE RecFieldsDotDot)     -- See Note [DotDot fields] in GHC.Hs.Pat-              -> Maybe Name -- The constructor (Nothing for an-                                --    out of scope constructor)+              -> Maybe (WithUserRdr Name)+                  -- The constructor (Nothing for an out of scope constructor)               -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields               -> RnM [LHsRecField GhcRn (LocatedA arg)]   -- Field Labels we need to fill in-    rn_dotdot (Just (L loc_e (RecFieldsDotDot n))) (Just con) flds -- ".." on record construction / pat match+    rn_dotdot (Just (L loc_e (RecFieldsDotDot n))) (Just qcon@(WithUserRdr _ con)) flds -- ".." on record construction / pat match       | not (isUnboundName con) -- This test is because if the constructor                                 -- isn't in scope the constructor lookup will add                                 -- an error but still return an unbound name. We@@ -900,7 +862,7 @@         do { dd_flag <- xoptM LangExt.RecordWildCards            ; checkErr dd_flag (needFlagDotDot ctxt)            ; (rdr_env, lcl_env) <- getRdrEnvs-           ; conInfo <- lookupConstructorInfo con+           ; conInfo <- lookupConstructorInfo qcon            ; when (conFieldInfo conInfo == ConHasPositionalArgs) (addErr (TcRnIllegalWildcardsInConstructor con))            ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldRdrs flds) @@ -1027,7 +989,7 @@                                  checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))                                  -- Discard any module qualifier (#11662)                                ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                               ; return (L (l2l loc) (HsVar noExtField (L (l2l loc) arg_rdr))) }+                               ; return (L (l2l loc) (mkHsVarWithUserRdr lbl (L (l2l loc) arg_rdr))) }                        else return arg              ; (arg'', fvs) <- rnLExpr arg'              ; let lbl' :: FieldOcc GhcRn@@ -1053,8 +1015,9 @@ getFieldRdrs :: [LHsRecField GhcRn arg] -> [RdrName] getFieldRdrs flds = map (foExt . unXRec @GhcRn . hfbLHS . unLoc) flds -getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [IdP p]-getFieldLbls = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p)+getFieldLbls :: [LHsRecField (GhcPass p) arg] -> [IdGhcP p]+getFieldLbls flds+  = map (unLoc . foLabel . unLoc . hfbLHS . unLoc) flds  needFlagDotDot :: HsRecFieldContext -> TcRnMessage needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart@@ -1063,8 +1026,8 @@ dupFieldErr ctxt = TcRnDuplicateFieldName (toRecordFieldPart ctxt)  toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart-toRecordFieldPart (HsRecFieldCon n)  = RecordFieldConstructor n-toRecordFieldPart (HsRecFieldPat n)  = RecordFieldPattern     n+toRecordFieldPart (HsRecFieldCon n)  = RecordFieldConstructor (getName n)+toRecordFieldPart (HsRecFieldPat n)  = RecordFieldPattern     (getName n) toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate  {- Note [Disambiguating record updates]@@ -1084,26 +1047,91 @@ the parent datatype by computing the parents (TyCon/PatSyn) which have at least one constructor (DataCon/PatSyn) with all of the fields. -For example, in the (non-overloaded) record update+To do this, given the (non-empty) set of fields in the record update,+lookupRecUpdFields proceeds as follows: -    r { fld1 = 3, fld2 = 'x' }+  (1) For each field, retrieve all the in-scope GREs that it could possibly+      refer to. -only the TyCon R contains at least one DataCon which has both of the fields-being updated: in this case, MkR1 and MkR2 have both of the updated fields.-The TyCon S also has both fields fld1 and fld2, but no single constructor-has both of those fields, so S is not a valid parent for this record update.+  (2) Take an intersection to compute the possible parent data constructors.+      For example, for an update -Note that this check is namespace-aware, so that a record update such as+        r { fld1 = 3, fld2 = 'x' } +      the possible parents for each field are:++        fld1: [MkR1 |-> R.fld1, MkR2 |-> R.fld1, MkS1 |> S.fld1]+        fld2: [MkR1 |-> R.fld2, MkR2 |-> R.fld2, MkS2 |> S.fld2]++      after intersecting by constructor, we get:++        fld1: [MkR1 |-> R.fld1, MkR2 |-> R.fld1]+        fld2: [MkR1 |-> R.fld2, MkR2 |-> R.fld2]++      This reflects the fact that only the TyCon R contains at least one DataCon+      which has both of the fields being updated: MkR1 and MkR2.+      The TyCon S also has both fields fld1 and fld2, but no single constructor+      has both of those fields, so S is not a valid parent for this record update.++  (3)+    (a)+      If there is at least one possible parent TyCon, succeed. The typechecker+      might still be able to disambiguate if there remains more than one+      candidate parent TyCon (see Note [Type-directed record disambiguation]).+    (b)+      Otherwise, report an error saying "No constructor has all these fields".+      This is the job of GHC.Rename.Env.badFieldsUpd. This function tries+      to report a minimal set of fields, so that in a record update like++        r { fld1 = x1, fld2 = x2, [...], fld99 = x99 }++      we don't report a massive error message saying "No constructor has all+      the fields fld1, ..., fld99" and instead report e.g. "No constructor+      has all the fields { fld3, fld17 }".++Wrinkle [Qualified names in record updates]++  Note that we must take into account qualified names in (1), so that a record+  update such as+     import qualified M ( R (fld1, fld2) )     f r = r { M.fld1 = 3 } -is unambiguous, as only R contains the field fld1 in the M namespace.-(See however #22122 for issues relating to the usage of exact Names in-record fields.)+  is unambiguous: only R contains the field fld1 with the M qualifier. -See also Note [Type-directed record disambiguation] in GHC.Tc.Gen.Expr.+  The function that looks up the GREs for the record update is 'lookupFieldGREs',+  which uses 'lookupGRE env (LookupRdrName ...)', ensuring that we correctly+  filter the GREs with the correct module qualification (with 'pickGREs'). +  (See however #22122 for issues relating to the usage of exact Names in+  record fields.)++Wrinkle [Out of scope constructors]++  For (3)(b), we have an invalid record update because no constructor has+  all of the fields of the record update. The 'badFieldsUpd' then tries to+  compute a minimal set of fields which are not children of any single+  constructor. The way this is done is explained in+  Note [Finding the conflicting fields] in GHC.Rename.Env, but in short that+  function needs a mapping from ConLike to all of its fields to do its business.+  (You may remark that we did not need such a mapping for step (2).)++  This means we need to look up each constructor and find its fields; this+  information is stored in the GREInfo field of a constructor GRE.+  We need this information even if the constructor itself is not in scope, so+  we proceed as follows:++    1. First look up the constructor in the GlobalRdrEnv, using lookupGRE_Name.+       This handles constructors defined in the current module being renamed,+       as well as in-scope imported constructors.+    2. If that fails (e.g. the field is imported but the constructor is not),+       then look up the GREInfo of the constructor in the TypeEnv, using+       lookupGREInfo. This makes sure we give the right error message even when+       the constructors are not in scope (#26391).++    Note that we do need (1), as (2) does not handle constructors defined in the+    current module being renamed (as those have not yet been added to the TypeEnv).+ Note [Using PatSyn FreeVars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we are disambiguating a non-overloaded record update, as per@@ -1183,9 +1211,9 @@               lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable                                               , ol_from_fun = L (noAnnSrcSpan loc) from_thing_name } }         ; if isNegativeZeroOverLit lit'-          then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName-                  ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)-                                  , fvs1 `plusFV` fvs2) }+          then do { (negate_expr, fvs2) <- lookupSyntaxExpr negateName+                  ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_expr)+                           , fvs1 `plusFV` fvs2) }           else return ((lit', Nothing), fvs1) }  @@ -1265,7 +1293,7 @@   hs_ty' <- rn_ty_pat hs_ty   pure (L l hs_ty') -rn_ty_pat_var :: LocatedN RdrName -> TPRnM (LocatedN Name)+rn_ty_pat_var :: LocatedN RdrName -> TPRnM (LocatedN (WithUserRdr Name)) rn_ty_pat_var lrdr@(L l rdr) = do   locals <- askLocals   if isRdrTyVar rdr@@ -1274,11 +1302,11 @@     then do -- binder       name <- liftTPRnCps $ newPatName (LamMk True) lrdr       tellTPB (tpBuilderExplicitTV name)-      pure (L l name)+      pure (L l $ WithUserRdr rdr name)      else do -- usage       name <- lookupTypeOccTPRnM rdr-      pure (L l name)+      pure (L l $ WithUserRdr rdr name)  -- | Rename type patterns --@@ -1286,13 +1314,13 @@ -- and Note [Implicit and explicit type variable binders] rn_ty_pat :: HsType GhcPs -> TPRnM (HsType GhcRn) rn_ty_pat tv@(HsTyVar an prom lrdr) = do-  lname@(L _ name) <- rn_ty_pat_var lrdr+  L l (WithUserRdr _ name) <- rn_ty_pat_var lrdr   when (isDataConName name && not (isKindName name)) $     -- Any use of a promoted data constructor name (that is not specifically     -- exempted by isKindName) is illegal without the use of DataKinds.     -- See Note [Checking for DataKinds] in GHC.Tc.Validity.     check_data_kinds tv-  pure (HsTyVar an prom lname)+  pure (HsTyVar an prom (L l $ WithUserRdr (unLoc lrdr) name))  rn_ty_pat (HsForAllTy an tele body) = liftTPRnRaw $ \ctxt locals thing_inside ->   bindHsForAllTelescope ctxt tele $ \tele' -> do@@ -1323,7 +1351,7 @@  rn_ty_pat (HsFunTy an mult lhs rhs) = do   lhs' <- rn_lty_pat lhs-  mult' <- rn_ty_pat_arrow mult+  mult' <- rn_ty_pat_mult mult   rhs' <- rn_lty_pat rhs   pure (HsFunTy an mult' lhs' rhs') @@ -1343,8 +1371,8 @@   ty1' <- rn_lty_pat ty1   l_op' <- rn_ty_pat_var l_op   ty2' <- rn_lty_pat ty2-  fix  <- liftRn $ lookupTyFixityRn l_op'-  let op_name = unLoc l_op'+  fix  <- liftRn $ lookupTyFixityRn $ fmap getName l_op'+  let op_name = getName l_op'   when (isDataConName op_name && not (isPromoted prom)) $     liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)   liftRn $ mkHsOpTyRn prom l_op' fix ty1' ty2'@@ -1411,29 +1439,14 @@       | hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty)       | otherwise                       = lhs_ty -rn_ty_pat (HsBangTy an bang_src lty) = do-  ctxt <- askDocContext-  lty'@(L _ ty') <- rn_lty_pat lty-  liftRn $ addErr $-    TcRnWithHsDocContext ctxt $-    TcRnUnexpectedAnnotation ty' bang_src-  pure (HsBangTy an bang_src lty')--rn_ty_pat ty@HsRecTy{} = do-  ctxt <- askDocContext-  liftRn $ addErr $-    TcRnWithHsDocContext ctxt $-    TcRnIllegalRecordSyntax (Left ty)-  pure (HsWildCardTy noExtField) -- trick to avoid `failWithTc`- rn_ty_pat ty@(XHsType{}) = do   ctxt <- askDocContext   liftRnFV $ rnHsType ctxt ty -rn_ty_pat_arrow :: HsArrow GhcPs -> TPRnM (HsArrow GhcRn)-rn_ty_pat_arrow (HsUnrestrictedArrow _) = pure (HsUnrestrictedArrow noExtField)-rn_ty_pat_arrow (HsLinearArrow _) = pure (HsLinearArrow noExtField)-rn_ty_pat_arrow (HsExplicitMult _ p)+rn_ty_pat_mult :: HsMultAnn GhcPs -> TPRnM (HsMultAnn GhcRn)+rn_ty_pat_mult (HsUnannotated _) = pure (HsUnannotated noExtField)+rn_ty_pat_mult (HsLinearAnn _) = pure (HsLinearAnn noExtField)+rn_ty_pat_mult (HsExplicitMult _ p)   = rn_lty_pat p <&> (\mult -> HsExplicitMult noExtField mult)  check_data_kinds :: HsType GhcPs -> TPRnM ()@@ -1540,7 +1553,7 @@   So we have at least three options where we could do free variable extraction:-HsConPatTyArg, ConPat, or a Match (used to represent a function LHS). And none+HsTyPat, ConPat, or a Match (used to represent a function LHS). And none of those would be general enough. Rather than make an arbitrary choice, we embrace left-to-right scoping in types and implement it with CPS, just like it's done for view patterns in terms.
compiler/GHC/Rename/Splice.hs view
@@ -13,7 +13,7 @@         -- Brackets         rnTypedBracket, rnUntypedBracket, -        checkThLocalName, traceSplice, SpliceInfo(..),+        checkThLocalName, checkThLocalNameWithLift, checkThLocalNameNoLift, traceSplice, SpliceInfo(..),         checkThLocalTyName,   ) where @@ -44,14 +44,14 @@  import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) -import GHC.Tc.Utils.Env     ( checkWellStaged, tcMetaTy )+import GHC.Tc.Utils.Env     ( tcMetaTy )  import GHC.Driver.DynFlags import GHC.Data.FastString import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Driver.Hooks-import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName+import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName                             , patQTyConName, quoteDecName, quoteExpName                             , quotePatName, quoteTypeName, typeQTyConName) @@ -70,6 +70,7 @@ import qualified GHC.Boot.TH.Syntax as TH (Q)  import qualified GHC.LanguageExtensions as LangExt+import qualified Data.Set as Set  {- ************************************************************************@@ -119,13 +120,13 @@  rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnTypedBracket e br_body-  = addErrCtxt (typedQuotationCtxtDoc br_body) $+  = addErrCtxt (TypedTHBracketCtxt br_body) $     do { checkForTemplateHaskellQuotes e           -- Check for nested brackets-       ; cur_stage <- getStage-       ; case cur_stage of-           { Splice _       -> return ()+       ; cur_level <- getThLevel+       ; case cur_level of+           { Splice _ _       -> return ()                -- See Note [Untyped quotes in typed splices and vice versa]            ; RunSplice _    ->                -- See Note [RunSplice ThLevel] in GHC.Tc.Types.@@ -140,21 +141,20 @@        ; recordThUse         ; traceRn "Renaming typed TH bracket" empty-       ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body-+       ; (body', fvs_e) <- setThLevel (Brack cur_level RnPendingTyped) $ rnLExpr br_body        ; return (HsTypedBracket noExtField body', fvs_e)         }  rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnUntypedBracket e br_body-  = addErrCtxt (untypedQuotationCtxtDoc br_body) $+  = addErrCtxt (UntypedTHBracketCtxt br_body) $     do { checkForTemplateHaskellQuotes e           -- Check for nested brackets-       ; cur_stage <- getStage-       ; case cur_stage of-           { Splice _       -> return ()+       ; cur_level <- getThLevel+       ; case cur_level of+           { Splice _ _       -> return ()                -- See Note [Untyped quotes in typed splices and vice versa]            ; RunSplice _    ->                -- See Note [RunSplice ThLevel] in GHC.Tc.Types.@@ -173,49 +173,31 @@        ; (body', fvs_e) <-          -- See Note [Rebindable syntax and Template Haskell]          unsetXOptM LangExt.RebindableSyntax $-         setStage (Brack cur_stage (RnPendingUntyped ps_var)) $-                  rn_utbracket cur_stage br_body+         setThLevel (UntypedBrack cur_level ps_var) $+                  rn_utbracket br_body        ; pendings <- readMutVar ps_var        ; return (HsUntypedBracket pendings body', fvs_e)         } -rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)-rn_utbracket outer_stage br@(VarBr _ flg rdr_name)-  = do { name <- lookupOccRn (unLoc rdr_name)+rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)+rn_utbracket (VarBr _ flg rdr_name)+  = do { name <- lookupOccRn (if flg then WL_Term else WL_Type) (unLoc rdr_name)+       ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name)+       ; if flg then checkThLocalNameNoLift res_name else checkThLocalTyName name        ; check_namespace flg name-       ; this_mod <- getModule--       ; when (flg && nameIsLocalOrFrom this_mod name) $-             -- Type variables can be quoted in TH. See #5721.-                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name-                    ; case mb_bind_lvl of-                        { Nothing -> return ()      -- Can happen for data constructors,-                                                    -- but nothing needs to be done for them--                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]-                             | isTopLevel top_lvl-                             -> when (isExternalName name) (keepAlive name)-                             | otherwise-                             -> do { traceRn "rn_utbracket VarBr"-                                      (ppr name <+> ppr bind_lvl-                                                <+> ppr outer_stage)-                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl) $-                                      TcRnTHError $ THNameError $ QuotedNameWrongStage br }-                        }-                    }        ; return (VarBr noExtField flg (noLocA name), unitFV name) } -rn_utbracket _ (ExpBr _ e) = do { (e', fvs) <- rnLExpr e+rn_utbracket (ExpBr _ e) = do { (e', fvs) <- rnLExpr e                                 ; return (ExpBr noExtField e', fvs) } -rn_utbracket _ (PatBr _ p)+rn_utbracket (PatBr _ p)   = rnPat ThPatQuote p $ \ p' -> return (PatBr noExtField p', emptyFVs) -rn_utbracket _ (TypBr _ t) = do { (t', fvs) <- rnLHsType TypBrCtx t+rn_utbracket (TypBr _ t) = do { (t', fvs) <- rnLHsType TypBrCtx t                                 ; return (TypBr noExtField t', fvs) } -rn_utbracket _ (DecBrL _ decls)+rn_utbracket (DecBrL _ decls)   = do { group <- groupDecls decls        ; gbl_env  <- getGblEnv        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }@@ -241,7 +223,7 @@                   }            }} -rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG"+rn_utbracket (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG"   -- | Ensure that we are not using a term-level name in a type-level namespace@@ -253,16 +235,6 @@   where     ns = nameNameSpace nm -typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc-typedQuotationCtxtDoc br_body-  = hang (text "In the Template Haskell typed quotation")-         2 (thTyBrackets . ppr $ br_body)--untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc-untypedQuotationCtxtDoc br_body-  = hang (text "In the Template Haskell quotation")-         2 (ppr br_body)- {- ********************************************************* *                                                      *@@ -301,32 +273,33 @@  rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars))                                                     -- Outside brackets, run splice-                   -> (Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, a))+                   -> (UntypedSpliceFlavour, HsUntypedSpliceResult z -> HsUntypedSplice GhcRn -> RnM a)                                                    -- Inside brackets, make it pending                    -> HsUntypedSplice GhcPs                    -> RnM (a, FreeVars)-rnUntypedSpliceGen run_splice pend_splice splice-  = addErrCtxt (spliceCtxt splice) $ do-    { stage <- getStage-    ; case stage of-        Brack _ RnPendingTyped+rnUntypedSpliceGen run_splice (flavour, run_pending) splice+  = addErrCtxt (UntypedSpliceCtxt splice) $ do+    { level <- getThLevel+    ; case level of+        TypedBrack {}           -> failWithTc $ thSyntaxError                         $ MismatchedSpliceType Untyped IsSplice -        Brack pop_stage (RnPendingUntyped ps_var)-          -> do { (splice', fvs) <- setStage pop_stage $-                                    rnUntypedSplice splice+        UntypedBrack pop_level ps_var+          -> do { (splice', fvs) <- setThLevel pop_level $+                                    rnUntypedSplice splice flavour                 ; loc  <- getSrcSpanM                 ; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)-                ; let (pending_splice, result) = pend_splice splice_name splice'+                ; result <- run_pending (HsUntypedSpliceNested splice_name) splice'                 ; ps <- readMutVar ps_var-                ; writeMutVar ps_var (pending_splice : ps)+                ; writeMutVar ps_var (PendingRnSplice splice_name splice' : ps)                 ; return (result, fvs) }          _ ->  do { checkTopSpliceAllowed splice+                 ; cur_level <- getThLevel                  ; (splice', fvs1) <- checkNoErrs $-                                      setStage (Splice Untyped) $-                                      rnUntypedSplice splice+                                      setThLevel (Splice Untyped cur_level) $+                                      rnUntypedSplice splice flavour                    -- checkNoErrs: don't attempt to run the splice if                    -- renaming it failed; otherwise we get a cascade of                    -- errors from e.g. unbound variables@@ -365,9 +338,11 @@             Nothing -> return splice             Just h  -> h splice +       -- TODO: Should call tcUntypedSplice here        ; let the_expr = case splice' of                 HsUntypedSpliceExpr _ e ->  e                 HsQuasiQuote _ q str -> mkQuasiQuoteExpr flavour q str+                XUntypedSplice {} -> pprPanic "runRnSplice: XUntypedSplice" (pprUntypedSplice False Nothing splice')               -- Typecheck the expression        ; meta_exp_ty   <- tcMetaTy meta_ty_name@@ -377,7 +352,7 @@               -- Run the expression        ; mod_finalizers_ref <- newTcRef []-       ; result <- setStage (RunSplice mod_finalizers_ref) $+       ; result <- setThLevel (RunSplice mod_finalizers_ref) $                      run_meta zonked_q_expr        ; mod_finalizers <- readTcRef mod_finalizers_ref        ; traceSplice (SpliceInfo { spliceDescription = what@@ -402,18 +377,22 @@                  UntypedDeclSplice -> True                  _                 -> False --------------------makePending :: UntypedSpliceFlavour-            -> Name-            -> HsUntypedSplice GhcRn-            -> PendingRnSplice-makePending flavour n (HsUntypedSpliceExpr _ e)-  = PendingRnSplice flavour n e-makePending flavour n (HsQuasiQuote _ quoter quote)-  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter quote) +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+recordPendingSplice :: SplicePointName -> HsImplicitLiftSplice -> PendingStuff -> TcM (HsExpr GhcRn)+recordPendingSplice sp pn (RnPending ref) = do+  let untyped_splice = XUntypedSplice pn+  updTcRef ref (PendingRnSplice sp untyped_splice : )+  return (HsUntypedSplice (HsUntypedSpliceNested sp) untyped_splice)+-- Splices are not lifted for typed brackets+-- See Note [Lifecycle of an typed splice, and PendingTcSplice]+recordPendingSplice sp pn (RnPendingTyped) = do+  let typed_splice = XTypedSplice pn+  return (HsTypedSplice (HsTypedSpliceNested sp) typed_splice)+recordPendingSplice _ _ (TcPending _ _ _) = panic "impossible"+ -------------------mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name+mkQuasiQuoteExpr :: UntypedSpliceFlavour -> LIdP GhcRn                  -> XRec GhcPs FastString                  -> LHsExpr GhcRn -- Return the expression (quoter "...quote...")@@ -421,12 +400,12 @@ mkQuasiQuoteExpr flavour quoter (L q_span' quote)   = L q_span $ HsApp noExtField (L q_span              $ HsApp noExtField (L q_span-                    (HsVar noExtField (L (l2l q_span) quote_selector)))+                    (mkHsVar (L (l2l q_span) quote_selector)))                                 quoterExpr)                     quoteExpr   where     q_span = noAnnSrcSpan (locA q_span')-    quoterExpr = L q_span $! HsVar noExtField $! (L (l2l q_span) quoter)+    quoterExpr = L (l2l quoter) $! mkHsVar          $! quoter     quoteExpr  = L q_span $! HsLit noExtField $! HsString NoSourceText quote     quote_selector = case flavour of                        UntypedExpSplice  -> quoteExpName@@ -441,38 +420,44 @@ -- We use "spn" (which is arbitrary) because it is brief but grepable-for. unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "spn")) -rnUntypedSplice :: HsUntypedSplice GhcPs -> RnM (HsUntypedSplice GhcRn, FreeVars)+rnUntypedSplice :: HsUntypedSplice GhcPs+                -> UntypedSpliceFlavour+                -> RnM ( HsUntypedSplice GhcRn+                       , FreeVars) -- Not exported...used for all-rnUntypedSplice (HsUntypedSpliceExpr annCo expr)+rnUntypedSplice (HsUntypedSpliceExpr _ expr) flavour   = do  { (expr', fvs) <- rnLExpr expr-        ; return (HsUntypedSpliceExpr annCo expr', fvs) }+        ; return (HsUntypedSpliceExpr (HsUserSpliceExt flavour) expr', fvs) } -rnUntypedSplice (HsQuasiQuote ext quoter quote)+rnUntypedSplice (HsQuasiQuote _ quoter quote) flavour   = do  { -- Rename the quoter; akin to the HsVar case of rnExpr-        ; quoter' <- lookupOccRn quoter-        ; this_mod <- getModule-        ; when (nameIsLocalOrFrom this_mod quoter') $-          checkThLocalName quoter'--        ; return (HsQuasiQuote ext quoter' quote, unitFV quoter') }+        ; quoter' <- lookupLocatedOccRn WL_TermVariable quoter+        ; let res_name = WithUserRdr (unLoc quoter) <$> quoter'+        ; checkThLocalNameNoLift res_name+        ; return (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter' quote, unitFV (unLoc quoter')) }  ----------------------rnTypedSplice :: LHsExpr GhcPs -- Typed splice expression+rnTypedSplice :: HsTypedSplice GhcPs -- Typed splice expression               -> RnM (HsExpr GhcRn, FreeVars)-rnTypedSplice expr-  = addErrCtxt (hang (text "In the typed splice:") 2 (pprTypedSplice Nothing expr)) $ do-    { stage <- getStage-    ; case stage of-        Brack pop_stage RnPendingTyped-          -> setStage pop_stage rn_splice+rnTypedSplice sp@(HsTypedSpliceExpr _ expr)+  = addErrCtxt (TypedSpliceCtxt Nothing sp) $ do+    { level <- getThLevel+    ; case level of+        TypedBrack pop_level+          -> do { loc <- getSrcSpanM+                ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)+                ; (e, fvs) <- setThLevel pop_level rn_splice+                ; return (HsTypedSplice (HsTypedSpliceNested n') (HsTypedSpliceExpr noExtField e), fvs)+                } -        Brack _ (RnPendingUntyped _)+        UntypedBrack {}           -> failWithTc $ thSyntaxError $ MismatchedSpliceType Typed IsSplice          _ -> do { unlessXOptM LangExt.TemplateHaskell                     (failWith $ thSyntaxError IllegalTHSplice) -                ; (result, fvs1) <- checkNoErrs $ setStage (Splice Typed) rn_splice+                ; cur_level <- getThLevel+                ; (result, fvs1) <- checkNoErrs $ setThLevel (Splice Typed cur_level) rn_splice                   -- checkNoErrs: don't attempt to run the splice if                   -- renaming it failed; otherwise we get a cascade of                   -- errors from e.g. unbound variables@@ -488,24 +473,18 @@                       lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)                       fvs2      = lcl_names `plusFV` gbl_names -                ; return (result, fvs1 `plusFV` fvs2) } }+                ; return (HsTypedSplice HsTypedSpliceTop (HsTypedSpliceExpr noExtField result), fvs1 `plusFV` fvs2) } }   where-    rn_splice :: RnM (HsExpr GhcRn, FreeVars)-    rn_splice =-      do { loc <- getSrcSpanM-         -- The renamer allocates a splice-point name to every typed splice-         -- (incl the top level ones for which it will not ultimately be used)-         ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)-         ; (expr', fvs) <- rnLExpr expr-         ; return (HsTypedSplice n' expr', fvs) }+    rn_splice :: RnM (LHsExpr GhcRn, FreeVars)+    rn_splice = rnLExpr expr  rnUntypedSpliceExpr :: HsUntypedSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnUntypedSpliceExpr splice   = rnUntypedSpliceGen run_expr_splice pend_expr_splice splice   where-    pend_expr_splice :: Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)-    pend_expr_splice name rn_splice-        = (makePending UntypedExpSplice name rn_splice, HsUntypedSplice (HsUntypedSpliceNested name) rn_splice)+    pend_expr_splice :: (UntypedSpliceFlavour, HsUntypedSpliceResult (HsExpr GhcRn) -> HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn))+    pend_expr_splice+      = (UntypedExpSplice, \x y -> pure $ HsUntypedSplice x y)      run_expr_splice rn_splice       = do { traceRn "rnUntypedSpliceExpr: untyped expression splice" empty@@ -687,9 +666,9 @@ rnSpliceType splice   = rnUntypedSpliceGen run_type_splice pend_type_splice splice   where-    pend_type_splice name rn_splice-       = ( makePending UntypedTypeSplice name rn_splice-         , HsSpliceTy (HsUntypedSpliceNested name) rn_splice)+    pend_type_splice+       = ( UntypedTypeSplice+         , \x y -> pure $ HsSpliceTy x y)      run_type_splice :: HsUntypedSplice GhcRn -> RnM (HsType GhcRn, FreeVars)     run_type_splice rn_splice@@ -767,9 +746,9 @@ rnSplicePat splice   = rnUntypedSpliceGen run_pat_splice pend_pat_splice splice   where-    pend_pat_splice name rn_splice-      = (makePending UntypedPatSplice name rn_splice-        , (rn_splice, HsUntypedSpliceNested name)) -- Pat splice is nested and thus simply renamed+    pend_pat_splice+      = (UntypedPatSplice+        , \x y -> pure (y, x)) -- Pat splice is nested and thus simply renamed      run_pat_splice rn_splice       = do { traceRn "rnSplicePat: untyped pattern splice" empty@@ -787,9 +766,9 @@ rnSpliceTyPat splice   = rnUntypedSpliceGen run_ty_pat_splice pend_ty_pat_splice splice   where-    pend_ty_pat_splice name rn_splice-      = (makePending UntypedTypeSplice name rn_splice-        , (rn_splice, HsUntypedSpliceNested name)) -- HsType splice is nested and thus simply renamed+    pend_ty_pat_splice+      = (UntypedTypeSplice+        , \x y -> pure (y, x))      run_ty_pat_splice rn_splice       = do { traceRn "rnSpliceTyPat: untyped pattern splice" empty@@ -806,9 +785,9 @@ rnSpliceDecl (SpliceDecl _ (L loc splice) flg)   = rnUntypedSpliceGen run_decl_splice pend_decl_splice splice   where-    pend_decl_splice name rn_splice-       = ( makePending UntypedDeclSplice name rn_splice-         , SpliceDecl noExtField (L loc rn_splice) flg)+    pend_decl_splice+       = ( UntypedDeclSplice+         , \_ y -> pure $ SpliceDecl noExtField (L loc y) flg)      run_decl_splice rn_splice  = pprPanic "rnSpliceDecl" (pprUntypedSplice True Nothing rn_splice) @@ -816,9 +795,10 @@ -- Declaration splice at the very top level of the module rnTopSpliceDecls splice    =  do { checkTopSpliceAllowed splice+         ; cur_level <- getThLevel          ; (rn_splice, fvs) <- checkNoErrs $-                               setStage (Splice Untyped) $-                               rnUntypedSplice splice+                               setThLevel (Splice Untyped cur_level) $+                               rnUntypedSplice splice UntypedDeclSplice            -- As always, be sure to checkNoErrs above lest we end up with            -- holes making it to typechecking, hence #12584.            --@@ -881,14 +861,6 @@ or its splice point name if nested (HsUntypedSpliceNested) -} -spliceCtxt :: HsUntypedSplice GhcPs -> SDoc-spliceCtxt splice-  = hang (text "In the" <+> what) 2 (pprUntypedSplice True Nothing splice)-  where-    what = case splice of-             HsUntypedSpliceExpr {} -> text "untyped splice:"-             HsQuasiQuote        {} -> text "quasi-quotation:"- -- | The splice data to be logged data SpliceInfo   = SpliceInfo@@ -942,113 +914,126 @@    | otherwise   = do  { traceRn "checkThLocalTyName" (ppr name)-        ; mb_local_use <- getStageAndBindLevel name+        ; mb_local_use <- getCurrentAndBindLevel name         ; case mb_local_use of {              Nothing -> return () ;  -- Not a locally-bound thing-             Just (top_lvl, bind_lvl, use_stage) ->-    do  { let use_lvl = thLevel use_stage-        -- We don't check the well stageness of name here.+             Just (top_lvl, bind_lvl, use_lvl) ->+    do  { let use_lvl_idx = thLevelIndex use_lvl+        -- We don't check the well levelledness of name here.         -- this would break test for #20969         --         -- Consequently there is no check&restiction for top level splices.         -- But it's annoying anyway.         ---        -- Therefore checkCrossStageLiftingTy shouldn't assume anything+        -- Therefore checkCrossLevelLiftingTy shouldn't assume anything         -- about bind_lvl and use_lvl relation.         ---        -- ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl-         ; traceRn "checkThLocalTyName" (ppr name <+> ppr bind_lvl-                                                 <+> ppr use_stage+                                                 <+> ppr use_lvl                                                  <+> ppr use_lvl)-        ; checkCrossStageLiftingTy top_lvl bind_lvl use_stage use_lvl name } } }+        ; dflags <- getDynFlags+        ; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl use_lvl_idx name } } } -checkThLocalName :: Name -> RnM ()-checkThLocalName name-  | isUnboundName name   -- Do not report two errors for-  = return ()            --   $(not_in_scope args)+-- | Check whether we are allowed to use a Name in this context (for TH purposes)+-- In the case of a level incorrect program, attempt to fix it by using+-- a Lift constraint.+checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM (HsExpr GhcRn)+checkThLocalNameWithLift = checkThLocalName True +-- | Check whether we are allowed to use a Name in this context (for TH purposes)+-- In the case of a level incorrect program, do not attempt to fix it by using+-- a Lift constraint.+checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM ()+checkThLocalNameNoLift name = checkThLocalName False name >> return ()++-- | Implemenation of the level checks+-- See Note [Template Haskell levels]+checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM (HsExpr GhcRn)+checkThLocalName allow_lifting name_var+  -- Exact and Orig names are not imported, so presumed available at all levels.+  | isExact (userRdrName (unLoc name_var)) || isOrig (userRdrName (unLoc name_var))+  = return (HsVar noExtField name_var)+  | isUnboundName name   -- Do not report two errors for+  = return (HsVar noExtField name_var)            --   $(not_in_scope args)+  | isWiredInName name+  = return (HsVar noExtField name_var)   | otherwise-  = do  { traceRn "checkThLocalName" (ppr name)-        ; mb_local_use <- getStageAndBindLevel name+  = do  {+          mb_local_use <- getCurrentAndBindLevel name         ; case mb_local_use of {-             Nothing -> return () ;  -- Not a locally-bound thing-             Just (top_lvl, bind_lvl, use_stage) ->-    do  { let use_lvl = thLevel use_stage-        ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl-        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl-                                               <+> ppr use_stage-                                               <+> ppr use_lvl)-        ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }+             Nothing -> return (HsVar noExtField name_var) ;  -- Not a locally-bound thing+             Just (top_lvl, bind_lvl, use_lvl) ->+    do  { let use_lvl_idx = thLevelIndex use_lvl+        ; cur_mod <- extractModule <$> getGblEnv+        ; let is_local+                  | Just mod <- nameModule_maybe name = mod == cur_mod+                  | otherwise = True+        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl <+> ppr use_lvl)+        ; dflags <- getDynFlags+        ; env <- getGlobalRdrEnv+        ; let mgre = lookupGRE_Name env name+        ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var } } }+  where+    name = getName name_var  ---------------------------------------checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel-                       -> Name -> TcM ()--- We are inside brackets, and (use_lvl > bind_lvl)--- Now we must check whether there's a cross-stage lift to do--- Examples   \x -> [| x |]---            [| map |]------ This code is similar to checkCrossStageLifting in GHC.Tc.Gen.Expr, but--- this is only run on *untyped* brackets.--checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name-  | Brack _ (RnPendingUntyped ps_var) <- use_stage   -- Only for untyped brackets-  , use_lvl > bind_lvl                               -- Cross-stage condition-  = check_cross_stage_lifting top_lvl name ps_var-  | otherwise-  = return ()--check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()-check_cross_stage_lifting top_lvl name ps_var+checkCrossLevelLifting :: DynFlags+                       -> LevelCheckReason+                       -> TopLevelFlag+                       -> Bool+                       -> Bool+                       -> Set.Set ThLevelIndex+                       -> ThLevel+                       -> ThLevelIndex+                       -> LIdOccP GhcRn+                       -> TcM (HsExpr GhcRn)+checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var+  -- 1. If name is in-scope, at the correct level.+  | use_lvl_idx `Set.member` bind_lvl = return (HsVar noExtField name_var)+  -- 2. Name is imported with -XImplicitStagePersistence+  | not is_local+  , xopt LangExt.ImplicitStagePersistence dflags = return (HsVar noExtField name_var)+  -- 3. Name is top-level, with -XImplicitStagePersistence, and needs+  -- to be persisted into the future.   | isTopLevel top_lvl-        -- Top-level identifiers in this module,-        -- (which have External Names)-        -- are just like the imported case:-        -- no need for the 'lifting' treatment-        -- E.g.  this is fine:-        --   f x = x-        --   g y = [| f 3 |]-  = when (isExternalName name) (keepAlive name)-    -- See Note [Keeping things alive for Template Haskell]--  | otherwise-  =     -- Nested identifiers, such as 'x' in-        -- E.g. \x -> [| h x |]-        -- We must behave as if the reference to x was-        --      h $(lift x)-        -- We use 'x' itself as the SplicePointName, used by-        -- the desugarer to stitch it all back together.-        -- If 'x' occurs many times we may get many identical-        -- bindings of the same SplicePointName, but that doesn't-        -- matter, although it's a mite untidy.-    do  { traceRn "checkCrossStageLifting" (ppr name)--          -- Construct the (lift x) expression-        ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)-              pend_splice = PendingRnSplice UntypedExpSplice name lift_expr--          -- Warning for implicit lift (#17804)-        ; addDetailedDiagnostic (TcRnImplicitLift name)+  , is_local+  , any (use_lvl_idx >=) (Set.toList bind_lvl)+  , xopt LangExt.ImplicitStagePersistence dflags = when (isExternalName name) (keepAlive name) >> return (HsVar noExtField name_var)+  -- 4. Name is in a bracket, and lifting is allowed+  | Brack _ pending <- use_lvl+  , any (use_lvl_idx >=) (Set.toList bind_lvl)+  , allow_lifting+  = do+       let mgre = case reason of+                   LevelCheckSplice _ gre -> gre+                   _ -> Nothing+       (splice_name :: Name) <- newLocalBndrRn (noLocA unqualSplice)+       let  pend_splice :: HsImplicitLiftSplice+            pend_splice = HsImplicitLiftSplice bind_lvl use_lvl_idx mgre name_var+       -- Warning for implicit lift (#17804)+       addDetailedDiagnostic (TcRnImplicitLift name) -          -- Update the pending splices-        ; ps <- readMutVar ps_var-        ; writeMutVar ps_var (pend_splice : ps) }+       -- Update the pending splices if we are renaming a typed bracket+       recordPendingSplice splice_name pend_splice pending+  -- Otherwise, we have a level error, report.+  | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx Nothing ErrorWithoutFlag ) >> return (HsVar noExtField name_var)+  where+    name = getName name_var -checkCrossStageLiftingTy :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel -> Name -> TcM ()-checkCrossStageLiftingTy top_lvl bind_lvl _use_stage use_lvl name+checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM ()+checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name   | isTopLevel top_lvl+  , xopt LangExt.ImplicitStagePersistence dflags   = return ()    -- There is no liftType (yet), so we could error, or more conservatively, just warn.   --   -- For now, we check here for both untyped and typed splices, as we don't create splices.-  | use_lvl > bind_lvl-  = addDiagnostic $ TcRnBadlyStagedType name bind_lvl use_lvl -  -- See comment in checkThLocalTyName: this can also happen.-  | bind_lvl < use_lvl-  = addDiagnostic $ TcRnBadlyStagedType name bind_lvl use_lvl+  -- Can also happen for negative cases+  -- See comment in checkThLocalTyName:+  | use_lvl_idx `notElem` bind_lvl+  = addDiagnostic $ TcRnBadlyLevelledType name bind_lvl use_lvl_idx    | otherwise   = return ()@@ -1089,7 +1074,7 @@ Note [Quoting names] ~~~~~~~~~~~~~~~~~~~~ A quoted name 'n is a bit like a quoted expression [| n |], except that we-have no cross-stage lifting (c.f. GHC.Tc.Gen.Expr.thBrackId).  So, after incrementing+have no cross-level lifting (c.f. GHC.Tc.Gen.Expr.thBrackId).  So, after incrementing the use-level to account for the brackets, the cases are:          bind > use                      Error@@ -1108,7 +1093,7 @@    \x. f 'x      -- Not ok (bind = 1, use = 1)                 -- (whereas \x. f [| x |] might have been ok, by-                --                               cross-stage lifting+                --                               cross-level lifting    \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1) 
compiler/GHC/Rename/Unbound.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-}  {-@@ -13,8 +14,8 @@    , mkUnboundGRERdr    , isUnboundName    , reportUnboundName-   , reportUnboundName'    , unknownNameSuggestions+   , unknownNameSuggestionsMessage    , similarNameSuggestions    , fieldSelectorSuggestions    , WhatLooking(..)@@ -25,7 +26,8 @@    , unboundTermNameInTypes    , IsTermInTypes(..)    , notInScopeErr-   , nameSpacesRelated+   , relevantNameSpace+   , suggestionIsRelevant    , termNameInType    ) where@@ -34,10 +36,13 @@  import GHC.Driver.DynFlags import GHC.Driver.Ppr+import GHC.Driver.Env (hsc_units)+import GHC.Driver.Env.Types +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( getHoleFitDispConfig ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad-import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique)+import GHC.Builtin.Names ( mkUnboundName, isUnboundName ) import GHC.Utils.Misc import GHC.Utils.Panic (panic) @@ -53,17 +58,18 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader-import GHC.Types.Unique.DFM (udfmToList)  import GHC.Unit.Module import GHC.Unit.Module.Imported-import GHC.Unit.Home.ModInfo+import GHC.Utils.Outputable+import GHC.Runtime.Context  import GHC.Data.Bag-import GHC.Utils.Outputable (empty)+import Language.Haskell.Syntax.ImpExp -import Data.List (sortBy, partition, nub)+import Data.List (sortBy, partition) import Data.List.NonEmpty ( pattern (:|), NonEmpty )+import qualified Data.List.NonEmpty as NE ( nonEmpty ) import Data.Function ( on ) import qualified Data.Semigroup as S import qualified Data.Map as M@@ -76,19 +82,6 @@ ************************************************************************ -} --- 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@@ -113,11 +106,8 @@ mkUnboundGRERdr :: RdrName -> GlobalRdrElt mkUnboundGRERdr rdr = mkLocalGRE UnboundGRE NoParent $ mkUnboundNameRdr rdr -reportUnboundName' :: WhatLooking -> RdrName -> RnM Name-reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr--reportUnboundName :: RdrName -> RnM Name-reportUnboundName = reportUnboundName' WL_Anything+reportUnboundName :: WhatLooking -> RdrName -> RnM Name+reportUnboundName what_look rdr = unboundName (LF what_look WL_Anywhere) rdr  unboundName :: LookingFor -> RdrName -> RnM Name unboundName lf rdr = unboundNameX lf rdr []@@ -141,17 +131,23 @@   = do  { dflags <- getDynFlags         ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags         ; if not show_helpful_errors-          then addErr $ make_error [] hints+          then addErr =<< make_error [] hints           else do { local_env  <- getLocalRdrEnv                   ; global_env <- getGlobalRdrEnv                   ; impInfo <- getImports                   ; currmod <- getModule-                  ; hpt <- getHpt+                  ; ic <- hsc_IC <$> getTopEnv                   ; let (imp_errs, suggs) =                           unknownNameSuggestions_ looking_for-                            dflags hpt currmod global_env local_env impInfo+                            dflags ic currmod global_env local_env impInfo                             rdr_name-                  ; addErr $+                  ; traceTc "unboundNameOrTermInType" $+                     vcat [ text "rdr_name:" <+> ppr rdr_name+                          , text "what_looking:" <+> text (show $ lf_which looking_for)+                          , text "imp_errs:" <+> ppr imp_errs+                          , text "suggs:" <+> ppr suggs+                          ]+                  ; addErr =<<                       make_error imp_errs (hints ++ suggs) }         ; return (mkUnboundNameRdr rdr_name) }     where@@ -162,10 +158,28 @@        err = notInScopeErr (lf_where looking_for) name_to_search -      make_error imp_errs hints = case if_term_in_type of-        TermInTypes demoted_name -> TcRnTermNameInType demoted_name hints-        _ -> TcRnNotInScope err name_to_search imp_errs hints+      make_error imp_errs hints =+        case if_term_in_type of+          TermInTypes demoted_name ->+            unknownNameSuggestionsMessage (TcRnTermNameInType demoted_name)+              [] -- no import errors+              hints+          _ -> unknownNameSuggestionsMessage (TcRnNotInScope err name_to_search)+                 imp_errs hints +unknownNameSuggestionsMessage :: TcRnMessage -> [ImportError] -> [GhcHint] -> RnM TcRnMessage+unknownNameSuggestionsMessage msg imp_errs hints+  = do { unit_state <- hsc_units <$> getTopEnv+       ; hfdc <- getHoleFitDispConfig+       ; let supp = case NE.nonEmpty imp_errs of+                       Nothing -> Nothing+                       Just ne_imp_errs ->+                         (Just (hfdc, [SupplementaryImportErrors ne_imp_errs]))+       ; return $+           TcRnMessageWithInfo unit_state $+             mkDetailedMessage (ErrInfo [] supp hints) msg+       }+ notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError notInScopeErr where_look rdr_name   | Just name <- isExact_maybe rdr_name@@ -179,17 +193,17 @@ unknownNameSuggestions :: LocalRdrEnv -> WhatLooking -> RdrName -> RnM ([ImportError], [GhcHint]) unknownNameSuggestions lcl_env what_look tried_rdr_name =   do { dflags  <- getDynFlags-     ; hpt     <- getHpt      ; rdr_env <- getGlobalRdrEnv      ; imp_info <- getImports      ; curr_mod <- getModule+     ; interactive_context <- hsc_IC <$> getTopEnv      ; return $         unknownNameSuggestions_           (LF what_look WL_Anywhere)-          dflags hpt curr_mod rdr_env lcl_env imp_info tried_rdr_name }+          dflags interactive_context curr_mod rdr_env lcl_env imp_info tried_rdr_name } -unknownNameSuggestions_ :: LookingFor -> DynFlags-                       -> HomePackageTable -> Module+unknownNameSuggestions_ :: LookingFor -> DynFlags -> InteractiveContext+                       -> Module                        -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails                        -> RdrName -> ([ImportError], [GhcHint]) unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env@@ -201,7 +215,7 @@       , map (ImportSuggestion $ rdrNameOcc tried_rdr_name) imp_suggs       , extensionSuggestions tried_rdr_name       , fieldSelectorSuggestions global_env tried_rdr_name ]-    (imp_errs, imp_suggs) = importSuggestions looking_for global_env hpt curr_mod imports tried_rdr_name+    (imp_errs, imp_suggs) = importSuggestions looking_for hpt curr_mod imports tried_rdr_name      if_ne :: (NonEmpty a -> b) -> [a] -> [b]     if_ne _ []       = []@@ -234,12 +248,11 @@      tried_occ     = rdrNameOcc tried_rdr_name     tried_is_sym  = isSymOcc tried_occ-    tried_ns      = occNameSpace tried_occ     tried_is_qual = isQual tried_rdr_name -    correct_name_space occ =-      (nameSpacesRelated dflags what_look tried_ns (occNameSpace occ))-      && isSymOcc occ == tried_is_sym+    is_relevant sugg_occ =+      suggestionIsRelevant dflags what_look sugg_occ+        && isSymOcc sugg_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)@@ -255,7 +268,8 @@       | otherwise     = [ (mkRdrUnqual occ, nameSrcSpan name)                         | name <- localRdrEnvElts env                         , let occ = nameOccName name-                        , correct_name_space occ]+                        , is_relevant occ+                        ]      global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)]     global_possibilities global_env@@ -263,7 +277,7 @@                         | gre <- globalRdrEnvElts global_env                         , isGreOk looking_for gre                         , let occ = greOccName gre-                        , correct_name_space occ+                        , is_relevant occ                         , (mod, how) <- qualsInScope gre                         , let rdr_qual = mkRdrQual mod occ ] @@ -272,7 +286,7 @@                     , isGreOk looking_for gre                     , let occ = greOccName gre                           rdr_unqual = mkRdrUnqual occ-                    , correct_name_space occ+                    , is_relevant occ                     , sim <- case (unquals_in_scope gre, quals_only gre) of                                 (how:_, _)    -> [ SimilarRdrName rdr_unqual (Just how) ]                                 ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]@@ -308,21 +322,19 @@  -- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope. importSuggestions :: LookingFor-                  -> GlobalRdrEnv-                  -> HomePackageTable -> Module+                  -> InteractiveContext -> Module                   -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion])-importSuggestions looking_for global_env hpt currMod imports rdr_name+importSuggestions looking_for ic currMod imports rdr_name   | WL_LocalOnly <- lf_where looking_for       = ([], [])   | WL_LocalTop  <- lf_where looking_for       = ([], [])   | not (isQual rdr_name || isUnqual rdr_name) = ([], [])-  | null interesting_imports-  , Just name <- mod_name+  | Just name <- mod_name   , show_not_imported_line name   = ([MissingModule name], [])   | is_qualified   , null helpful_imports   , (mod : mods) <- map fst interesting_imports-  = ([ModulesDoNotExport (mod :| mods) occ_name], [])+  = ([ModulesDoNotExport (mod :| mods) (lf_which looking_for) occ_name], [])   | mod : mods <- helpful_imports_non_hiding   = ([], [CouldImportFrom (mod :| mods)])   | mod : mods <- helpful_imports_hiding@@ -344,6 +356,17 @@     , Just imp <- return $ pick (importedByUser mod_imports)     ] +  -- Choose the imports from the interactive context which might have provided+  -- a module.+  interactive_imports =+    filter pick_interactive (ic_imports ic)++  pick_interactive :: InteractiveImport -> Bool+  pick_interactive (IIDecl d)   | mod_name == Just (unLoc (ideclName d)) = True+                                | mod_name == fmap unLoc (ideclAs d) = True+  pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True+  pick_interactive _ = False+   -- We want to keep only one for each original module; preferably one with an   -- explicit import list (for no particularly good reason)   pick :: [ImportedModsVal] -> Maybe ImportedModsVal@@ -369,17 +392,10 @@   -- 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` glob_mods               = False    -- #14225     -- 1-      | moduleName currMod == modnam          = False                  -- 2.1-      | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2+      | not (null interactive_imports)        = False -- 1 (interactive context)+      | not (null interesting_imports)        = False -- 1 (normal module import)+      | moduleName currMod == modnam          = False -- 2       | otherwise                             = True-    where-      hpt_uniques = map fst (udfmToList hpt)-      is_last_loaded_mod modnam uniqs = lastMaybe uniqs == Just (getUnique modnam)-      glob_mods = nub [ mod-                      | gre <- globalRdrEnvElts global_env-                      , (mod, _) <- qualsInScope gre-                      ]  extensionSuggestions :: RdrName -> [GhcHint] extensionSuggestions rdrName@@ -414,41 +430,44 @@                  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+-- | Is it OK to suggest an identifier in some other 'NameSpace',+-- given what we are looking for?+--+-- See Note [Related name spaces]+suggestionIsRelevant+  :: DynFlags    -- ^ to find out whether -XDataKinds is enabled+  -> WhatLooking -- ^ What kind of name are we looking for?+  -> OccName     -- ^ The suggestion+                 --+                 -- We only look at the suggestion's 'NameSpace',+                 -- but passing the whole 'OccName' is convenient+                 -- for debugging.+  -> Bool+suggestionIsRelevant dflags what_looking suggestion =+  relevantNameSpace data_kinds what_looking suggestion_ns+    where+      suggestion_ns = occNameSpace suggestion+      data_kinds = xopt LangExt.DataKinds dflags++-- | Is a 'NameSpace' relevant for what we are looking for?+relevantNameSpace :: Bool        -- ^ is @-XDataKinds@ enabled?+                  -> WhatLooking -- ^ what are we looking for?+                  -> NameSpace   -- ^ is this 'NameSpace' relevant?                   -> Bool-nameSpacesRelated dflags what_looking ns ns'-  | ns == ns'-  = True-  | otherwise-  = or [ other_ns ns'-       | (orig_ns, others) <- other_namespaces-       , orig_ns 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 =-      [ (isVarNameSpace     , [(isFieldNameSpace  , [WL_RecField])-                              ,(isDataConNameSpace, [WL_Constructor])])-      , (isDataConNameSpace , [(isVarNameSpace    , [WL_RecField])])-      , (isTvNameSpace      , (isTcClsNameSpace   , [WL_Constructor])-                              : promoted_datacons)-      , (isTcClsNameSpace   , (isTvNameSpace     , [])-                              : 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 = [(isDataConNameSpace, [WL_Constructor]) | data_kinds]+relevantNameSpace data_kinds = \case+  WL_Anything         -> const True+  WL_TyCon            -> isTcClsNameSpace+  WL_TyCon_or_TermVar -> isTcClsNameSpace <||> isTermVarOrFieldNameSpace+  WL_TyVar            -> isTvNameSpace+  WL_Constructor      -> isTcClsNameSpace <||> isDataConNameSpace+  WL_ConLike          -> isDataConNameSpace+  WL_RecField         -> isFieldNameSpace+  WL_Term             -> isValNameSpace+  WL_TermVariable     -> isTermVarOrFieldNameSpace+  WL_Type             -> if data_kinds+                         then not . isTermVarOrFieldNameSpace+                         else not . isValNameSpace+  WL_None             -> const False  {- Note [Related name spaces] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -478,13 +497,8 @@     Module X does not export Y     No module named ‘X’ is imported: there are 2 cases, where we hide the last "no module is imported" line:-1. If the module X has been imported.-2. If the module X is the current module. There are 2 subcases:-   2.1 If the unknown module name is in a input source file,-       then we can use the getModule function to get the current module name.-       (See test T15611a)-   2.2 If the unknown module name has been entered by the user in GHCi,-       then the getModule function returns something like "interactive:Ghci1",-       and we have to check the current module in the last added entry of-       the HomePackageTable. (See test T15611b)+1. If the module X has been imported (normally or via interactive context).+2. It is the current module we are trying to compile+   then we can use the getModule function to get the current module name.+   (See test T15611a) -}
compiler/GHC/Rename/Utils.hs view
@@ -25,10 +25,9 @@         genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat,         genVarPat, genWildPat,         genSimpleFunBind, genFunBind,--        genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch,+        genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch, genHsLet, -        genHsLet,+        mkRnSyntaxExpr,          newLocalBndrRn, newLocalBndrsRn, @@ -43,7 +42,7 @@ where  -import GHC.Prelude hiding (unzip)+import GHC.Prelude  import GHC.Core.Type import GHC.Hs@@ -75,9 +74,8 @@ import GHC.Iface.Load import qualified GHC.LanguageExtensions as LangExt -import qualified Data.List as List import qualified Data.List.NonEmpty as NE-import Data.Foldable+import Data.Foldable (for_) import Data.Maybe  @@ -108,7 +106,7 @@ bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names   = updLclCtxt $ \ lcl_env ->-    let th_level  = thLevel (tcl_th_ctxt lcl_env)+    let th_level  = thLevelIndex (tcl_th_ctxt lcl_env)         th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)                     [ (n, (NotTopLevel, th_level)) | n <- names ]         rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names@@ -347,11 +345,6 @@         (ys, fvs_s) -> return (ys, foldl' (flip plusFV) emptyFVs fvs_s) {-# SPECIALIZE mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) #-} -unzip :: Functor f => f (a, b) -> (f a, f b)-unzip = \ xs -> (fmap fst xs, fmap snd xs)-{-# NOINLINE [1] unzip #-}-{-# RULES "unzip/List" unzip = List.unzip #-}- mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }@@ -546,9 +539,9 @@ lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeclDeprec iface gre   -- Bleat if the thing, or its parent, is warn'd-  = mi_decl_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`+  = mi_decl_warn_fn iface (greOccName gre) `mplus`     case greParent gre of-       ParentIs p -> mi_decl_warn_fn (mi_final_exts iface) (nameOccName p)+       ParentIs p -> mi_decl_warn_fn iface (nameOccName p)        NoParent   -> Nothing  warnIfExportDeprecated :: GlobalRdrElt -> RnM ()@@ -569,7 +562,7 @@     process_import_spec is = do       let mod = is_mod $ is_decl is       iface <- loadInterfaceForModule doc mod-      let mb_warn_txt = mi_export_warn_fn (mi_final_exts iface) name+      let mb_warn_txt = mi_export_warn_fn iface name       return $ (moduleName mod, ) <$> mb_warn_txt  -------------------------@@ -679,7 +672,7 @@ badQualBndrErr rdr_name = TcRnQualifiedBinder rdr_name  typeAppErr :: TypeOrKind -> LHsType GhcPs -> TcRnMessage-typeAppErr what (L _ k) = TcRnTypeApplicationsDisabled (TypeApplication k what)+typeAppErr what (L _ k) = TcRnTypeApplicationsDisabled k what  badFieldConErr :: Name -> FieldLabelString -> TcRnMessage badFieldConErr con field = TcRnInvalidRecordField con field@@ -713,6 +706,14 @@ -- See Note [Rebindable syntax and XXExprGhcRn] wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x +-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the+-- renamer).+mkRnSyntaxExpr :: Name -> SyntaxExprRn+mkRnSyntaxExpr = SyntaxExprRn . genHsVar++genHsVar :: Name -> HsExpr GhcRn+genHsVar n = mkHsVar (wrapGenSpan n)+ genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn genHsApps fun args = foldl genHsApp (genHsVar fun) args @@ -733,9 +734,6 @@ genLHsVar :: Name -> LHsExpr GhcRn genLHsVar nm = wrapGenSpan $ genHsVar nm -genHsVar :: Name -> HsExpr GhcRn-genHsVar nm = HsVar noExtField $ wrapGenSpan nm- genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) (mkEmptyWildCardBndrs (wrapGenSpan ty)) @@ -752,8 +750,8 @@ -- The pattern (C p1 .. pn) genSimpleConPat con pats   = wrapGenSpan $ ConPat { pat_con_ext = noExtField-                         , pat_con     = wrapGenSpan con-                         , pat_args    = PrefixCon [] pats }+                         , pat_con     = wrapGenSpan $ noUserRdr con+                         , pat_args    = PrefixCon pats }  genVarPat :: Name -> LPat GhcRn genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n)
compiler/GHC/Runtime/Eval.hs view
@@ -2,8 +2,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2005-2007@@ -20,12 +18,12 @@         abandon, abandonAll,         getResumeContext,         getHistorySpan,-        getModBreaks,+        getModBreaks, readIModBreaks, readIModModBreaks,         getHistoryModule,         setupBreakpoint,         back, forward,         setContext, getContext,-        mkTopLevEnv,+        mkTopLevEnv, mkTopLevImportedEnv,         getNamesInScope,         getRdrNamesInScope,         moduleIsInterpreted,@@ -55,7 +53,7 @@ import GHC.Driver.Ppr import GHC.Driver.Config -import GHC.Rename.Names (importsFromIface)+import GHC.Rename.Names (importsFromIface, gresFromAvails)  import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi@@ -66,6 +64,7 @@ import GHC.ByteCode.Types  import GHC.Linker.Loader as Loader+import GHC.Linker.Types (LinkedBreaks (..))  import GHC.Hs @@ -74,6 +73,7 @@ import GHC.Core.InstEnv import GHC.Core.Predicate import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Tidy( tidyType, tidyOpenTypes ) import GHC.Core.TyCon import GHC.Core.Type       hiding( typeKind ) import qualified GHC.Core.Type as Type@@ -112,35 +112,31 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.DSet import GHC.Types.TyThing-import GHC.Types.Breakpoint import GHC.Types.Unique.Map +import GHC.Types.Avail import GHC.Unit import GHC.Unit.Module.Graph import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModSummary import GHC.Unit.Home.ModInfo -import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces )+import GHC.Tc.Module ( runTcInteractive, tcRnTypeSkolemising, loadUnqualIfaces ) import GHC.Tc.Solver (simplifyWantedsTcM)-import GHC.Tc.Utils.Env (tcGetInstEnvs, lookupGlobal)+import GHC.Tc.Utils.Env (tcGetInstEnvs) import GHC.Tc.Utils.Instantiate (instDFunType) import GHC.Tc.Utils.Monad-import GHC.Tc.Zonk.Env ( ZonkFlexi (SkolemiseFlexi) ) -import GHC.Unit.Env import GHC.IfaceToCore+import GHC.ByteCode.Breakpoints  import Control.Monad-import Control.Monad.Catch as MC-import Data.Array import Data.Dynamic import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap import Data.List (find,intercalate) import Data.List.NonEmpty (NonEmpty)-import System.Directory import Unsafe.Coerce ( unsafeCoerce )+import qualified GHC.Unit.Home.Graph as HUG+import GHCi.BreakArray (BreakArray)  -- ----------------------------------------------------------------------------- -- running a statement interactively@@ -148,27 +144,29 @@ getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) -mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> History-mkHistory hsc_env hval ibi = History hval ibi (findEnclosingDecls hsc_env ibi)+mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History+mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi -getHistoryModule :: History -> Module-getHistoryModule = ibi_tick_mod . historyBreakpointId+getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module+getHistoryModule hug hist = do+  let ibi = historyBreakpointId hist+  brks <- readIModBreaks hug ibi+  return $ getBreakSourceMod ibi brks -getHistorySpan :: HscEnv -> History -> SrcSpan-getHistorySpan hsc_env hist =-  let ibi = historyBreakpointId hist in-  case lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env) of-    Just hmi -> modBreaks_locs (getModBreaks hmi) ! ibi_tick_index ibi-    _ -> panic "getHistorySpan"+getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan+getHistorySpan hug hist = do+  let ibi = historyBreakpointId hist+  brks <- readIModBreaks hug ibi+  getBreakLoc (readIModModBreaks hug) ibi brks  {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick.-findEnclosingDecls :: HscEnv -> InternalBreakpointId -> [String]-findEnclosingDecls hsc_env ibi =-   let hmi = expectJust "findEnclosingDecls" $ lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env)-   in modBreaks_decls (getModBreaks hmi) ! ibi_tick_index ibi+findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String]+findEnclosingDecls hug ibi = do+  brks <- readIModBreaks hug ibi+  getBreakDecls (readIModModBreaks hug) ibi brks  -- | Update fixity environment in the current interactive context. updateFixityEnv :: GhcMonad m => FixityEnv -> m ()@@ -232,10 +230,9 @@         updateFixityEnv fix_env          status <--          withVirtualCWD $-            liftIO $ do-              let eval_opts = initEvalOpts idflags' (isStep execSingleStep)-              evalStmt interp eval_opts (execWrap hval)+          liftIO $ do+            let eval_opts = initEvalOpts idflags' (enableGhcStepMode execSingleStep)+            evalStmt interp eval_opts (execWrap hval)          let ic = hsc_IC hsc_env             bindings = (ic_tythings ic, ic_gre_cache ic)@@ -282,38 +279,17 @@ See #11051 for more background and examples. -} -withVirtualCWD :: GhcMonad m => m a -> m a-withVirtualCWD m = do-  hsc_env <- getSession--    -- a virtual CWD is only necessary when we're running interpreted code in-    -- the same process as the compiler.-  case interpInstance <$> hsc_interp hsc_env of-    Just (ExternalInterp {}) -> m-    _ -> do-      let ic = hsc_IC hsc_env-      let set_cwd = do-            dir <- liftIO $ getCurrentDirectory-            case ic_cwd ic of-               Just dir -> liftIO $ setCurrentDirectory dir-               Nothing  -> return ()-            return dir--          reset_cwd orig_dir = do-            virt_dir <- liftIO $ getCurrentDirectory-            hsc_env <- getSession-            let old_IC = hsc_IC hsc_env-            setSession hsc_env{  hsc_IC = old_IC{ ic_cwd = Just virt_dir } }-            liftIO $ setCurrentDirectory orig_dir--      MC.bracket set_cwd reset_cwd $ \_ -> m- parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr  emptyHistory :: Int -> BoundedList History emptyHistory size = nilBL size +-- | Turn an 'EvalStatus_' result from interpreting Haskell into a GHCi 'ExecResult'.+--+-- This function is responsible for resuming execution at an intermediate+-- breakpoint if we don't care about that breakpoint (e.g. if using :steplocal+-- or :stepmodule, rather than :step, we only care about certain breakpoints). handleRunStatus :: GhcMonad m                 => SingleStep -> String                 -> ResumeBindings@@ -322,87 +298,115 @@                 -> BoundedList History                 -> m ExecResult -handleRunStatus step expr bindings final_ids status history-  | RunAndLogSteps <- step = tracing-  | otherwise              = not_tracing- where-  tracing-    | EvalBreak apStack_ref (Just eval_break) resume_ctxt _ccs <- status-    = do-       hsc_env <- getSession-       let interp = hscInterp hsc_env-       let dflags = hsc_dflags hsc_env-       let ibi = evalBreakpointToId (hsc_HPT hsc_env) eval_break-       let hmi = expectJust "handleRunStatus" $ lookupHpt (hsc_HPT hsc_env) (moduleName (ibi_tick_mod ibi))-           breaks = getModBreaks hmi+handleRunStatus step expr bindings final_ids status history0 = do+  hsc_env <- getSession+  let+    interp = hscInterp hsc_env+    dflags = hsc_dflags hsc_env+  case status of -       b <- liftIO $-              breakpointStatus interp (modBreaks_flags breaks) (ibi_tick_index ibi)-       if b-         then not_tracing-           -- This breakpoint is explicitly enabled; we want to stop-           -- instead of just logging it.-         else do-           apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref-           let !history' = mkHistory hsc_env apStack_fhv ibi `consBL` history-                 -- history is strict, otherwise our BoundedList is pointless.-           fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt-           let eval_opts = initEvalOpts dflags True-           status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv-           handleRunStatus RunAndLogSteps expr bindings final_ids-                           status history'-    | otherwise-    = not_tracing+    -- Completed successfully+    EvalComplete allocs (EvalSuccess hvals) -> do+      let+        final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids+        final_names = map getName final_ids+      liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)+      hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}+      setSession hsc_env'+      return (ExecComplete (Right final_names) allocs) -  not_tracing-    -- Hit a breakpoint-    | EvalBreak apStack_ref maybe_break resume_ctxt ccs <- status-    = do-         hsc_env <- getSession-         let interp = hscInterp hsc_env-         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt-         apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref-         let ibi = evalBreakpointToId (hsc_HPT hsc_env) <$> maybe_break-         (hsc_env1, names, span, decl) <- liftIO $-           bindLocalsAtBreakpoint hsc_env apStack_fhv ibi-         let-           resume = Resume-             { resumeStmt = expr-             , resumeContext = resume_ctxt_fhv-             , resumeBindings = bindings-             , resumeFinalIds = final_ids-             , resumeApStack = apStack_fhv-             , resumeBreakpointId = ibi-             , resumeSpan = span-             , resumeHistory = toListBL history-             , resumeDecl = decl-             , resumeCCS = ccs-             , resumeHistoryIx = 0-             }-           hsc_env2 = pushResume hsc_env1 resume+    -- Completed with an exception+    EvalComplete alloc (EvalException e) ->+      return (ExecComplete (Left (fromSerializableException e)) alloc) -         setSession hsc_env2-         return (ExecBreak names ibi)+    -- Nothing case: we stopped when an exception was raised, not at a breakpoint.+    EvalBreak apStack_ref Nothing resume_ctxt ccs -> do+      resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt+      apStack_fhv     <- liftIO $ mkFinalizedHValue interp apStack_ref+      let span = mkGeneralSrcSpan (fsLit "<unknown>")+      (hsc_env1, names) <- liftIO $+        bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing+      let+        resume = Resume+          { resumeStmt = expr+          , resumeContext = resume_ctxt_fhv+          , resumeBindings = bindings+          , resumeFinalIds = final_ids+          , resumeApStack = apStack_fhv+          , resumeBreakpointId = Nothing+          , resumeSpan = span+          , resumeHistory = toListBL history0+          , resumeDecl = "<exception thrown>"+          , resumeCCS = ccs+          , resumeHistoryIx = 0+          }+        hsc_env2 = pushResume hsc_env1 resume -    -- Completed successfully-    | EvalComplete allocs (EvalSuccess hvals) <- status-    = do hsc_env <- getSession-         let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids-             final_names = map getName final_ids-             interp = hscInterp hsc_env-         liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)-         hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}-         setSession hsc_env'-         return (ExecComplete (Right final_names) allocs)+      setSession hsc_env2+      return (ExecBreak names Nothing) -    -- Completed with an exception-    | EvalComplete alloc (EvalException e) <- status-    = return (ExecComplete (Left (fromSerializableException e)) alloc)+    -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint+    --+    -- The interpreter yields on a breakpoint if:+    --  - the breakpoint was explicitly enabled (in @BreakArray@)+    --  - or one of the stepping options in @EvalOpts@ caused us to stop at one+    EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do+      let ibi = evalBreakpointToId eval_break+      let hug = hsc_HUG hsc_env+      info_brks  <- liftIO $ readIModBreaks hug ibi+      span <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks+      decl <- liftIO $ intercalate "." <$> getBreakDecls (readIModModBreaks hug) ibi info_brks +      -- Was this breakpoint explicitly enabled (ie. in @BreakArray@)?+      bactive <- liftIO $ do+        breakArray <- getBreakArray interp ibi info_brks+        breakpointStatus interp breakArray (ibi_info_index ibi) -resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int+      apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref+      resume_ctxt_fhv   <- liftIO $ mkFinalizedHValue interp resume_ctxt++      -- This breakpoint is enabled or we mean to break here;+      -- we want to stop instead of just logging it.+      if breakHere bactive step span then do+        -- This function only returns control to ghci with 'ExecBreak' when it is really meant to break.+        -- Specifically, for :steplocal or :stepmodule, don't return control+        -- and simply resume execution from here until we hit a breakpoint we do want to stop at.+        (hsc_env1, names) <- liftIO $+          bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi)+        let+          resume = Resume+            { resumeStmt = expr+            , resumeContext = resume_ctxt_fhv+            , resumeBindings = bindings+            , resumeFinalIds = final_ids+            , resumeApStack = apStack_fhv+            , resumeBreakpointId = Just ibi+            , resumeSpan = span+            , resumeHistory = toListBL history0+            , resumeDecl = decl+            , resumeCCS = ccs+            , resumeHistoryIx = 0+            }+          hsc_env2 = pushResume hsc_env1 resume+        setSession hsc_env2+        return (ExecBreak names (Just ibi))+      else do+        -- resume with the same step type+        let eval_opts = initEvalOpts dflags (enableGhcStepMode step)+        status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv+        history <- if not tracing then pure history0 else do+          history1 <- liftIO $ mkHistory hug apStack_fhv ibi+          let !history' = history1 `consBL` history0+                -- history is strict, otherwise our BoundedList is pointless.+          return history'+        handleRunStatus step expr bindings final_ids status history+ where+  tracing | RunAndLogSteps <- step = True+          | otherwise              = False++resumeExec :: GhcMonad m => SingleStep -> Maybe Int            -> m ExecResult-resumeExec canLogSpan step mbCnt+resumeExec step mbCnt  = do    hsc_env <- getSession    let ic = hsc_IC hsc_env@@ -440,42 +444,61 @@                  , resumeBreakpointId = mb_brkpt                  , resumeSpan = span                  , resumeHistory = hist } ->-               withVirtualCWD $ do+               do                 -- When the user specified a break ignore count, set it                 -- in the interpreter                 case (mb_brkpt, mbCnt) of-                  (Just brkpt, Just cnt) -> setupBreakpoint hsc_env (toBreakpointId brkpt) cnt+                  (Just brkpt, Just cnt) -> setupBreakpoint interp brkpt cnt                   _ -> return () -                let eval_opts = initEvalOpts dflags (isStep step)+                let eval_opts = initEvalOpts dflags (enableGhcStepMode step)                 status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv                 let prevHistoryLst = fromListBL 50 hist+                    hug = hsc_HUG hsc_env                     hist' = case mb_brkpt of-                       Nothing -> prevHistoryLst+                       Nothing -> pure prevHistoryLst                        Just bi-                         | not $ canLogSpan span -> prevHistoryLst-                         | otherwise -> mkHistory hsc_env apStack bi `consBL`-                                                        fromListBL 50 hist-                handleRunStatus step expr bindings final_ids status hist'+                         | breakHere False step span -> do+                            hist1 <- liftIO (mkHistory hug apStack bi)+                            return $ hist1 `consBL` fromListBL 50 hist+                         | otherwise -> pure prevHistoryLst+                handleRunStatus step expr bindings final_ids status =<< hist' -setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m ()   -- #19157-setupBreakpoint hsc_env bi cnt = do-  let modl = bi_tick_mod bi-      breaks hsc_env modl = getModBreaks $ expectJust "setupBreakpoint" $-         lookupHpt (hsc_HPT hsc_env) (moduleName modl)-      modBreaks  = breaks hsc_env modl-      breakarray = modBreaks_flags modBreaks-      interp = hscInterp hsc_env-  _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt-  pure ()+setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m ()   -- #19157+setupBreakpoint interp ibi cnt = do+  hug <- hsc_HUG <$> getSession+  liftIO $ do+    modBreaks <- readIModBreaks hug ibi+    breakArray <- getBreakArray interp ibi modBreaks+    GHCi.storeBreakpoint interp breakArray (ibi_info_index ibi) cnt -back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)+getBreakArray :: Interp -> InternalBreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray)+getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do+  breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp+  case lookupModuleEnv (breakarray_env breaks0) ibi_info_mod of+    Just ba -> return ba+    Nothing -> do+      modifyLoaderState interp $ \ld_st -> do+        let lb = linked_breaks ld_st++        -- Recall that BreakArrays are allocated only at BCO link time, so if we+        -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here.+        ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs]++        let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} }+        let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env ibi_info_mod++        return+          ( ld_st'+          , ba+          )+back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) back n = moveHist (+n) -forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)+forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) forward n = moveHist (subtract n) -moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)+moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) moveHist fn = do   hsc_env <- getSession   case ic_resume (hsc_IC hsc_env) of@@ -493,15 +516,21 @@          let           update_ic apStack mb_info = do-            (hsc_env1, names, span, decl) <--              liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info+            span <- case mb_info of+                      Nothing  -> return $ mkGeneralSrcSpan (fsLit "<unknown>")+                      Just ibi -> liftIO $ do+                        let hug = hsc_HUG hsc_env+                        brks <- readIModBreaks hug ibi+                        getBreakLoc (readIModModBreaks hug) ibi brks+            (hsc_env1, names) <-+              liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info             let ic = hsc_IC hsc_env1                 r' = r { resumeHistoryIx = new_ix }                 ic' = ic { ic_resume = r':rs }              setSession hsc_env1{ hsc_IC = ic' } -            return (names, new_ix, span, decl)+            return (names, new_ix, span)          -- careful: we want apStack to be the AP_STACK itself, not a thunk         -- around it, hence the cases are carefully constructed below to@@ -525,16 +554,16 @@ bindLocalsAtBreakpoint         :: HscEnv         -> ForeignHValue+        -> SrcSpan         -> Maybe InternalBreakpointId-        -> IO (HscEnv, [Name], SrcSpan, String)+        -> IO (HscEnv, [Name])  -- Nothing case: we stopped when an exception was raised, not at a -- breakpoint.  We have no location information or local variables to -- bind, all we can do is bind a local variable to the exception -- value.-bindLocalsAtBreakpoint hsc_env apStack Nothing = do+bindLocalsAtBreakpoint hsc_env apStack span Nothing = do    let exn_occ = mkVarOccFS (fsLit "_exception")-       span    = mkGeneralSrcSpan (fsLit "<unknown>")    exn_name <- newInteractiveBinder hsc_env exn_occ span     let e_fs    = fsLit "e"@@ -547,30 +576,21 @@        interp = hscInterp hsc_env    --    Loader.extendLoadedEnv interp [(exn_name, apStack)]-   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")+   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name])  -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression.-bindLocalsAtBreakpoint hsc_env apStack_fhv (Just ibi) = do-   let-       interp    = hscInterp hsc_env--       info_mod  = ibi_info_mod ibi-       info_hmi  = expectJust "bindLocalsAtBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName info_mod)-       info_brks = getModBreaks info_hmi-       info      = expectJust "bindLocalsAtBreakpoint2" $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks)--       tick_mod  = ibi_tick_mod ibi-       tick_hmi  = expectJust "bindLocalsAtBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName tick_mod)-       tick_brks = getModBreaks tick_hmi-       occs      = modBreaks_vars tick_brks ! ibi_tick_index ibi-       span      = modBreaks_locs tick_brks ! ibi_tick_index ibi-       decl      = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi+bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do+   let hug = hsc_HUG hsc_env+   info_brks <- readIModBreaks hug ibi+   let info   = getInternalBreak ibi info_brks+       interp = hscInterp hsc_env+   occs <- getBreakVars (readIModModBreaks hug) ibi info_brks    -- Rehydrate to understand the breakpoint info relative to the current environment.   -- This design is critical to preventing leaks (#22530)    (mbVars, result_ty) <- initIfaceLoad hsc_env-                            $ initIfaceLcl info_mod (text "debugger") NotBoot+                            $ initIfaceLcl (ibi_info_mod ibi) (text "debugger") NotBoot                             $ hydrateCgBreakInfo info     let@@ -617,7 +637,7 @@    Loader.extendLoadedEnv interp (zip names fhvs)    when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)]    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }-   return (hsc_env1, if result_ok then result_name:names else names, span, decl)+   return (hsc_env1, if result_ok then result_name:names else names)   where         -- We need a fresh Unique for each Id we bind, because the linker         -- state is single-threaded and otherwise we'd spam old bindings@@ -654,7 +674,7 @@    syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs      where        joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]-       joinOccs = zipWithEqual "bindLocalsAtBreakpoint" joinOcc+       joinOccs = zipWithEqual joinOcc        joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc  rttiEnvironment :: HscEnv -> IO HscEnv@@ -669,7 +689,7 @@      noSkolems = noFreeVarsOfType . idType      improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do       let tmp_ids = [id | AnId id <- ic_tythings ic]-          Just id = find (\i -> idName i == name) tmp_ids+          id = expectJust $ find (\i -> idName i == name) tmp_ids       if noSkolems id          then return hsc_env          else do@@ -815,7 +835,7 @@       text "to context:" <+> text err  findGlobalRdrEnv :: HscEnv -> [InteractiveImport]-                 -> IO (Either (ModuleName, String) GlobalRdrEnv)+                 -> IO (Either (Module, String) GlobalRdrEnv) -- Compute the GlobalRdrEnv for the interactive context findGlobalRdrEnv hsc_env imports   = do { idecls_env <- hscRnImportDecls hsc_env idecls@@ -828,38 +848,50 @@     idecls :: [LImportDecl GhcPs]     idecls = [noLocA d | IIDecl d <- imports] -    imods :: [ModuleName]+    imods :: [Module]     imods = [m | IIModule m <- imports] -    mkEnv mod = mkTopLevEnv hsc_env mod >>= \case-      Left err -> pure $ Left (mod, err)-      Right env -> pure $ Right env+    mkEnv mod = do+      mkTopLevEnv hsc_env mod >>= \case+        Left err -> pure $ Left (mod, err)+        Right env -> pure $ Right env -mkTopLevEnv :: HscEnv -> ModuleName -> IO (Either String GlobalRdrEnv)+mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv) mkTopLevEnv hsc_env modl-  = case lookupHpt hpt modl of+  = HUG.lookupHugByModule modl hug >>= \case       Nothing -> pure $ Left "not a home module"       Just details ->          case mi_top_env (hm_iface details) of-                Nothing  -> pure $ Left "not interpreted"-                Just (IfaceTopEnv exports imports) -> do-                  imports_env <--                        runInteractiveHsc hsc_env-                      $ ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env-                      $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv)-                      $ forM imports $ \iface_import -> do-                        let ImpUserSpec spec details = tcIfaceImport hsc_env iface_import-                        iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec)-                        pure $ case details of-                          ImpUserAll -> importsFromIface hsc_env iface spec Nothing-                          ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns)-                          ImpUserExplicit x -> x-                  let get_GRE_info nm = tyThingGREInfo <$> lookupGlobal hsc_env nm-                  let exports_env = hydrateGlobalRdrEnv get_GRE_info exports+                (IfaceTopEnv exports _imports) -> do+                  imports_env <- mkTopLevImportedEnv hsc_env details+                  let exports_env = mkGlobalRdrEnv $ gresFromAvails hsc_env Nothing (getDetOrdAvails exports)                   pure $ Right $ plusGlobalRdrEnv imports_env exports_env   where-    hpt = hsc_HPT hsc_env+    hug = hsc_HUG hsc_env +-- | Make the top-level environment with all bindings imported by this module.+-- Exported bindings from this module are not included in the result.+mkTopLevImportedEnv :: HscEnv -> HomeModInfo -> IO GlobalRdrEnv+mkTopLevImportedEnv hsc_env details = do+    runInteractiveHsc hsc_env+  $ ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env+  $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv)+  $ forM imports $ \iface_import -> do+    let ImpUserSpec spec details = tcIfaceImport iface_import+    iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec)+    pure $ case details of+      ImpUserAll -> importsFromIface hsc_env iface spec Nothing+      ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns)+      ImpUserExplicit x _parents_of_implicits ->+        -- TODO: Not quite right, is_explicit should refer to whether the user wrote A(..) or A(x,y).+        -- It is only used for error messages. It seems dubious even to add an import context to these GREs as+        -- they are not "imported" into the top-level scope of the REPL. I changed this for now so that+        -- the test case produce the same output as before.+        let spec' = ImpSpec { is_decl = spec, is_item = ImpSome { is_explicit = True, is_iloc = noSrcSpan } }+        in mkGlobalRdrEnv $ gresFromAvails hsc_env (Just spec') x+  where+    IfaceTopEnv _ imports = mi_top_env (hm_iface details)+ -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively.@@ -871,11 +903,9 @@ -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h ->- if notHomeModule (hsc_home_unit h) modl-        then return False-        else case lookupHpt (hsc_HPT h) (moduleName modl) of-                Just details       -> return (isJust (mi_top_env (hm_iface details)))-                _not_a_home_module -> return False+  liftIO (HUG.lookupHugByModule modl (hsc_HUG h)) >>= \case+    Just hmi           -> return (isJust $ homeModInfoByteCode hmi)+    _not_a_home_module -> return False  -- | Looks up an identifier in the current interactive context (for :info) -- Filter the instances by the ones whose tycons (or classes resp)@@ -1072,8 +1102,9 @@   (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do     hsc_env <- getHscEnv     ty <- hscParseType str-    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty-+    ioMsgMaybe $ hoistTcRnMessage $+                 tcRnTypeSkolemising hsc_env ty+      -- I'm not sure what to do about those zonked skolems   return ty  -- Get all the constraints required of a dictionary binding@@ -1083,7 +1114,7 @@   let dict_var = mkVanillaGlobal dictName theta   loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing -  return CtWanted {+  return $ CtWanted $ WantedCt {     ctev_pred = varType dict_var,     ctev_dest = EvVarDest dict_var,     ctev_loc = loc,@@ -1240,7 +1271,7 @@         _ -> panic "compileParsedExprRemote"    updateFixityEnv fix_env-  let eval_opts = initEvalOpts dflags False+  let eval_opts = initEvalOpts dflags EvalStepNone   status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io)   case status of     EvalComplete _ (EvalSuccess [hval]) -> return hval@@ -1260,29 +1291,30 @@   parsed_expr <- parseExpr expr   -- > Data.Dynamic.toDyn expr   let loc = getLoc parsed_expr-      to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (l2l loc) $ getRdrName toDynName)+      to_dyn_expr = mkHsApp (L loc . mkHsVar . L (l2l loc) $ getRdrName toDynName)                             parsed_expr   hval <- compileParsedExpr to_dyn_expr   return (unsafeCoerce hval :: Dynamic)  -------------------------------------------------------------------------------- show a module and it's source/object filenames+-- show a module and its source/object filenames -showModule :: GhcMonad m => ModSummary -> m String-showModule mod_summary =+showModule :: GhcMonad m => ModuleNodeInfo -> m String+showModule mni = do+    let mod = moduleNodeInfoModule mni     withSession $ \hsc_env -> do         let dflags = hsc_dflags hsc_env-        let interpreted =-              case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of-               Nothing       -> panic "missing linkable"-               Just mod_info -> isJust (homeModInfoByteCode mod_info)  && isNothing (homeModInfoObject mod_info)-        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary))+        interpreted <- liftIO $+          HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case+            Nothing       -> panic "missing linkable"+            Just mod_info -> isJust (homeModInfoByteCode mod_info)  && isNothing (homeModInfoObject mod_info)+        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mni)) -moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool-moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->-  case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of-        Nothing       -> panic "missing linkable"-        Just mod_info -> return . isNothing $ homeModInfoByteCode mod_info+moduleIsBootOrNotObjectLinkable :: GhcMonad m => Module -> m Bool+moduleIsBootOrNotObjectLinkable mod = withSession $ \hsc_env -> liftIO $+  HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case+    Nothing       -> panic "missing linkable"+    Just mod_info -> isNothing $ homeModInfoByteCode mod_info  ---------------------------------------------------------------------------- -- RTTI primitives
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -1,5 +1,16 @@ {-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ > 912+{-# OPTIONS_GHC -Wwarn=incomplete-record-selectors #-}+-- This module has a bunch of uses of incomplete record selectors+-- and it is FAR from obvious that they won't cause crashes.+-- But I don't want them to kill CI, so the above flag turns+-- them into warnings+#endif++ ----------------------------------------------------------------------------- -- -- GHC Interactive support for inspecting arbitrary closures at runtime@@ -33,6 +44,7 @@  import GHC.Core.DataCon import GHC.Core.Type+import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped ) import GHC.Types.RepType import GHC.Core.Multiplicity import qualified GHC.Core.Unify as U@@ -75,6 +87,7 @@ import Data.Sequence (viewl, ViewL(..)) import Foreign hiding (shiftL, shiftR) import System.IO.Unsafe+import GHC.InfoProv  --------------------------------------------- -- * A representation of semi evaluated Terms@@ -95,6 +108,7 @@                        , ty       :: RttiType                        , val      :: ForeignHValue                        , bound_to :: Maybe Name   -- Useful for printing+                       , infoprov :: Maybe InfoProv -- Provenance is printed when available                        }           | NewtypeWrap{       -- At runtime there are no newtypes, and hence no                                -- newtype constructors. A NewtypeWrap is just a@@ -117,6 +131,11 @@ isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t isFullyEvaluatedTerm _                  = False +-- | Gives an error if the term doesn't have subterms+expectSubTerms :: Term -> [Term]+expectSubTerms (Term { subTerms = subTerms} ) = subTerms+expectSubTerms _                              = panic "expectSubTerms"+ instance Outputable (Term) where  ppr t | Just doc <- cPprTerm cPprTermBase t = doc        | otherwise = panic "Outputable Term instance"@@ -148,7 +167,7 @@ data TermFold a = TermFold { fTerm        :: TermProcessor a a                            , fPrim        :: RttiType -> [Word] -> a                            , fSuspension  :: ClosureType -> RttiType -> ForeignHValue-                                            -> Maybe Name -> a+                                            -> Maybe Name -> Maybe InfoProv -> a                            , fNewtypeWrap :: RttiType -> Either String DataCon                                             -> a -> a                            , fRefWrap     :: RttiType -> a -> a@@ -159,7 +178,7 @@                    TermFoldM {fTermM        :: TermProcessor a (m a)                             , fPrimM        :: RttiType -> [Word] -> m a                             , fSuspensionM  :: ClosureType -> RttiType -> ForeignHValue-                                             -> Maybe Name -> m a+                                             -> Maybe Name -> Maybe InfoProv -> m a                             , fNewtypeWrapM :: RttiType -> Either String DataCon                                             -> a -> m a                             , fRefWrapM     :: RttiType -> a -> m a@@ -168,7 +187,7 @@ foldTerm :: TermFold a -> Term -> a foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) foldTerm tf (Prim ty    v   ) = fPrim tf ty v-foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b+foldTerm tf (Suspension ct ty v b i) = fSuspension tf ct ty v b i foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t) foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t) @@ -176,7 +195,7 @@ foldTermM :: Monad m => TermFoldM m a -> Term -> m a foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v foldTermM tf (Prim ty    v   ) = fPrimM tf ty v-foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b+foldTermM tf (Suspension ct ty v b i) = fSuspensionM tf ct ty v b i foldTermM tf (NewtypeWrap ty dc t)  = foldTermM tf t >>=  fNewtypeWrapM tf ty dc foldTermM tf (RefWrap ty t)         = foldTermM tf t >>= fRefWrapM tf ty @@ -192,8 +211,8 @@ mapTermType :: (RttiType -> Type) -> Term -> Term mapTermType f = foldTerm idTermFold {           fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,-          fSuspension = \ct ty hval n ->-                          Suspension ct (f ty) hval n,+          fSuspension = \ct ty hval n i ->+                          Suspension ct (f ty) hval n i,           fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,           fRefWrap    = \ty t -> RefWrap (f ty) t} @@ -201,8 +220,8 @@ mapTermTypeM f = foldTermM TermFoldM {           fTermM       = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty'  dc hval tt,           fPrimM       = (return.) . Prim,-          fSuspensionM = \ct ty hval n ->-                          f ty >>= \ty' -> return $ Suspension ct ty' hval n,+          fSuspensionM = \ct ty hval n i ->+                          f ty >>= \ty' -> return $ Suspension ct ty' hval n i,           fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,           fRefWrapM    = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} @@ -210,7 +229,7 @@ termTyCoVars = foldTerm TermFold {             fTerm       = \ty _ _ tt   ->                           tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,-            fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,+            fSuspension = \_ ty _ _ _ -> tyCoVarsOfType ty,             fPrim       = \ _ _ -> emptyVarSet,             fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,             fRefWrap    = \ty t -> tyCoVarsOfType ty `unionVarSet` t}@@ -268,8 +287,24 @@ ppr_termM1 :: Monad m => Term -> m SDoc ppr_termM1 Prim{valRaw=words, ty=ty} =     return $ repPrim (tyConAppTyCon ty) words-ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =-    return (char '_' <+> whenPprDebug (dcolon <> pprSigmaType ty))+ppr_termM1 Suspension{ty=ty, bound_to=Nothing, infoprov=mipe} =+  return $ hcat $+    [ char '_'+    , whenPprDebug $+        space <>+        dcolon <>+        pprSigmaType ty+    ] +++    [ whenPprDebug $+        space <>+        char '<' <>+        text (ipSrcFile ipe) <>+        char ':' <>+        text (ipSrcSpan ipe) <>+        char '>'+    | Just ipe <- [mipe]+    , not $ null $ ipSrcFile ipe+    ] ppr_termM1 Suspension{ty=ty, bound_to=Just n}   | otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType ty ppr_termM1 Term{}        = panic "ppr_termM1 - Term"@@ -321,8 +356,8 @@ cPprTermBase y =   [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)                                       . mapM (y (-1))-                                      . subTerms)-  , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)+                                      . expectSubTerms)+  , ifTerm (\t -> isTyCon listTyCon (ty t) && expectSubTerms t `lengthIs` 2)            ppr_list   , ifTerm' (isTyCon intTyCon     . ty) ppr_int   , ifTerm' (isTyCon charTyCon    . ty) ppr_char@@ -757,12 +792,24 @@     traceTR (text "Gave up reconstructing a term after" <>                   int max_depth <> text " steps")     clos <- trIO $ GHCi.getClosure interp a-    return (Suspension (tipe (info clos)) my_ty a Nothing)+    ipe  <- trIO $ GHCi.whereFrom interp a+#ifndef MIN_VERSION_ghc_heap+#define MIN_VERSION_ghc_heap(major1,major2,minor) (\+  (major1) <  9 || \+  (major1) == 9 && (major2) <  14 || \+  (major1) == 9 && (major2) == 14 && (minor) <= 1)+#endif /* MIN_VERSION_ghc_heap */+#if MIN_VERSION_ghc_heap(9,15,0)+    return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing ipe)+#else+    return (Suspension (tipe (info clos)) my_ty a Nothing ipe)+#endif   go !max_depth my_ty old_ty a = do     let monomorphic = not(isTyVarTy my_ty)     -- This ^^^ is a convention. The ancestor tests for     -- monomorphism and passes a type instead of a tv     clos <- trIO $ GHCi.getClosure interp a+    ipe  <- trIO $ GHCi.whereFrom interp a     case clos of -- Thunks we may want to force       t | isThunk t && force -> do@@ -781,7 +828,8 @@       BlackholeClosure{indirectee=ind} -> do          traceTR (text "Following a BLACKHOLE")          ind_clos <- trIO (GHCi.getClosure interp ind)-         let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing)+         ind_ipe  <- trIO (GHCi.whereFrom interp ind)+         let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing ind_ipe)          case ind_clos of            -- TSO and BLOCKING_QUEUE cases            BlockingQueueClosure{} -> return_bh_value@@ -839,7 +887,7 @@           Just dc -> do             traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))             subTtypes <- getDataConArgTys dc my_ty-            subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes+            subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) pArgs dArgs subTtypes             return (Term my_ty (Right dc) a subTerms)        -- This is to support printing of Integers. It's not a general@@ -853,8 +901,17 @@       _ -> do          traceTR (text "Unknown closure:" <+>                   text (show (fmap (const ()) clos)))-         return (Suspension (tipe (info clos)) my_ty a Nothing)-+#ifndef MIN_VERSION_ghc_heap+#define MIN_VERSION_ghc_heap(major1,major2,minor) (\+  (major1) <  9 || \+  (major1) == 9 && (major2) <  14 || \+  (major1) == 9 && (major2) == 14 && (minor) <= 1)+#endif /* MIN_VERSION_ghc_heap */+#if MIN_VERSION_ghc_heap(9,15,0)+         return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing ipe)+#else+         return (Suspension (tipe (info clos)) my_ty a Nothing ipe)+#endif   -- insert NewtypeWraps around newtypes   expandNewtypes = foldTerm idTermFold { fTerm = worker } where    worker ty dc hval tt@@ -869,15 +926,16 @@     -- Avoid returning types where predicates have been expanded to dictionaries.   fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where-      worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n-                          | otherwise  = Suspension ct ty hval n+      worker ct ty hval n i | isFunTy ty = Suspension ct (dictsView ty) hval n i+                            | otherwise  = Suspension ct ty hval n i  extractSubTerms :: (Type -> ForeignHValue -> TcM Term)-                -> GenClosure ForeignHValue -> [Type] -> TcM [Term]-extractSubTerms recurse clos = liftM thdOf3 . go 0 0+                -> [ForeignHValue] -- ^ pointer arguments+                -> [Word]          -- ^ data arguments+                -> [Type]+                -> TcM [Term]+extractSubTerms recurse ptr_args data_args = liftM thdOf3 . go 0 0   where-    array = dataArgs clos-     go ptr_i arr_i [] = return (ptr_i, arr_i, [])     go ptr_i arr_i (ty:tys)       | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty@@ -907,7 +965,7 @@      go_rep ptr_i arr_i ty rep       | isGcPtrRep rep = do-          t <- recurse ty $ (ptrArgs clos)!!ptr_i+          t <- recurse ty $ ptr_args !! ptr_i           return (ptr_i + 1, arr_i, t)       | otherwise = do           -- This is a bit involved since we allow packing multiple fields@@ -928,7 +986,7 @@                  | otherwise =                      let (q, r) = size_b `quotRem` word_size                      in assert (r == 0 )-                        [ array!!i+                        [ data_args !! i                         | o <- [0.. q - 1]                         , let i = (aligned_idx `quot` word_size) + o                         ]@@ -951,7 +1009,7 @@       LittleEndian -> (word `shiftR` moveBits) `shiftL` zeroOutBits `shiftR` zeroOutBits      where       (q, r) = aligned_idx `quotRem` word_size-      word = array!!q+      word = data_args !! q       moveBits = r * 8       zeroOutBits = (word_size - size_b) * 8 @@ -1093,7 +1151,7 @@ -- The types can contain skolem type variables, which need to be treated as normal vars. -- In particular, we want them to unify with things. improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe Subst-improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty+improveRTTIType _ base_ty new_ty = U.tcUnifyDebugger base_ty new_ty  getDataConArgTys :: DataCon -> Type -> TR [Type] -- Given the result type ty of a constructor application (D a b c :: ty)@@ -1370,8 +1428,8 @@ zonkTerm = foldTermM (TermFoldM              { fTermM = \ty dc v tt -> zonkRttiType ty    >>= \ty' ->                                        return (Term ty' dc v tt)-             , fSuspensionM  = \ct ty v b -> zonkRttiType ty >>= \ty ->-                                             return (Suspension ct ty v b)+             , fSuspensionM  = \ct ty v b i -> zonkRttiType ty >>= \ty ->+                                               return (Suspension ct ty v b i)              , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->                                            return$ NewtypeWrap ty' dc t              , fRefWrapM     = \ty t -> return RefWrap  `ap`
compiler/GHC/Runtime/Interpreter.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}  -- | Interacting with the iserv interpreter, whether it is running on an -- external process or in the current process.@@ -20,16 +21,17 @@   , mkCostCentres   , costCentreStackInfo   , newBreakArray-  , newModuleName   , storeBreakpoint   , breakpointStatus   , getBreakpointVar   , getClosure+  , whereFrom   , getModBreaks+  , readIModBreaks+  , readIModBreaksMaybe+  , readIModModBreaks   , seqHValue   , evalBreakpointToId-  , interpreterDynamic-  , interpreterProfiled    -- * The object-code linker   , initObjLinker@@ -74,16 +76,15 @@ import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray)-import GHC.Types.Breakpoint-import GHC.ByteCode.Types+import GHC.ByteCode.Breakpoints +import GHC.ByteCode.Types import GHC.Linker.Types  import GHC.Data.Maybe import GHC.Data.FastString  import GHC.Types.SrcLoc-import GHC.Types.Unique.FM import GHC.Types.Basic  import GHC.Utils.Panic@@ -92,13 +93,11 @@ import GHC.Utils.Fingerprint  import GHC.Unit.Module-import GHC.Unit.Module.ModIface import GHC.Unit.Home.ModInfo import GHC.Unit.Env  #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run-import GHC.Platform.Ways #endif  import Control.Concurrent@@ -107,14 +106,20 @@ import Control.Monad.Catch as MC (mask) import Data.Binary import Data.ByteString (ByteString)-import Data.Array ((!))-import Data.IORef import Foreign hiding (void) import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS (CostCentre,CostCentreStack) import System.Directory import System.Process+import qualified GHC.InfoProv as InfoProv +import GHC.Builtin.Names+import GHC.Types.Name+import qualified GHC.Unit.Home.Graph as HUG++-- Standard libraries+import GHC.Exts+ {- Note [Remote GHCi]    ~~~~~~~~~~~~~~~~~~ When the flag -fexternal-interpreter is given to GHC, interpreted code@@ -369,10 +374,6 @@   breakArray <- interpCmd interp (NewBreakArray size)   mkFinalizedHValue interp breakArray -newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)-newModuleName interp mod_name =-  castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name))- storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO () storeBreakpoint interp ref ix cnt = do                               -- #19157   withForeignRef ref $ \breakarray ->@@ -395,6 +396,11 @@     mb <- interpCmd interp (GetClosure hval)     mapM (mkFinalizedHValue interp) mb +whereFrom :: Interp -> ForeignHValue -> IO (Maybe InfoProv.InfoProv)+whereFrom interp ref =+  withForeignRef ref $ \hval -> do+    interpCmd interp (WhereFrom hval)+ -- | Send a Seq message to the iserv process to force a value      #2950 seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ()) seqHValue interp unit_env ref =@@ -402,15 +408,16 @@     status <- interpCmd interp (Seq hval)     handleSeqHValueStatus interp unit_env status -evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> InternalBreakpointId-evalBreakpointToId hpt eval_break =-  let load_mod x = mi_module $ hm_iface $ expectJust "evalBreakpointToId" $ lookupHpt hpt (mkModuleName x)-  in InternalBreakpointId-        { ibi_tick_mod   = load_mod (eb_tick_mod eval_break)-        , ibi_tick_index = eb_tick_index eval_break-        , ibi_info_mod   = load_mod (eb_info_mod eval_break)-        , ibi_info_index = eb_info_index eval_break-        }+evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId+evalBreakpointToId eval_break =+  let+    mkUnitId u = fsToUnit $ mkFastStringShortByteString u+    toModule u n = mkModule (mkUnitId u) (mkModuleName n)+  in+    InternalBreakpointId+      { ibi_info_mod   = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)+      , ibi_info_index = eb_info_index eval_break+      }  -- | Process the result of a Seq or ResumeSeq message.             #2950 handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())@@ -420,27 +427,33 @@       -- A breakpoint was hit; inform the user and tell them       -- which breakpoint was hit.       resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt-      let bp = evalBreakpointToId (ue_hpt unit_env) <$> maybe_break-          sdocBpLoc = brackets . ppr . getSeqBpSpan-      putStrLn ("*** Ignoring breakpoint " ++-            (showSDocUnsafe $ sdocBpLoc bp))++      let put x = putStrLn ("*** Ignoring breakpoint " ++ (showSDocUnsafe x))+      let nothing_case = put $ brackets . ppr $ mkGeneralSrcSpan (fsLit "<unknown>")+      case maybe_break of+        Nothing -> nothing_case+          -- Nothing case - should not occur!+          -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq++        Just break -> do+          let ibi = evalBreakpointToId break+              hug = ue_home_unit_graph unit_env++          -- Just case: Stopped at a breakpoint, extract SrcSpan information+          -- from the breakpoint.+          mb_modbreaks <- readIModBreaksMaybe hug (ibi_info_mod ibi)+          case mb_modbreaks of+            -- Nothing case - should not occur! We should have the appropriate+            -- breakpoint information+            Nothing -> nothing_case+            Just modbreaks -> put . brackets . ppr =<<+              getBreakLoc (readIModModBreaks hug) ibi modbreaks+       -- resume the seq (:force) processing in the iserv process       withForeignRef resume_ctxt_fhv $ \hval -> do         status <- interpCmd interp (ResumeSeq hval)         handleSeqHValueStatus interp unit_env status     (EvalComplete _ r) -> return r-  where-    getSeqBpSpan :: Maybe InternalBreakpointId -> SrcSpan-    getSeqBpSpan = \case-      Just bi -> (modBreaks_locs (breaks (ibi_tick_mod bi))) ! ibi_tick_index bi-        -- Just case: Stopped at a breakpoint, extract SrcSpan information-        -- from the breakpoint.-      Nothing -> mkGeneralSrcSpan (fsLit "<unknown>")-        -- Nothing case - should not occur!-        -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq-        ---    breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $-      lookupHpt (ue_hpt unit_env) (moduleName mod)   -- -----------------------------------------------------------------------------@@ -449,38 +462,65 @@ initObjLinker :: Interp -> IO () initObjLinker interp = interpCmd interp InitLinker -lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))+lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ())) lookupSymbol interp str = withSymbolCache interp str $   case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)-    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))+    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str))) #endif     ExternalInterp ext -> case ext of       ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do         uninterruptibleMask_ $-          sendMessage inst (LookupSymbol (unpackFS str))+          sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))       ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)       ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do         uninterruptibleMask_ $-          sendMessage inst (LookupSymbol (unpackFS str))+          sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) -lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))+lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ())) lookupSymbolInDLL interp dll str = withSymbolCache interp str $   case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)-    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))+    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) #endif     ExternalInterp ext -> case ext of       ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do         uninterruptibleMask_ $-          sendMessage inst (LookupSymbolInDLL dll (unpackFS str))+          sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))       ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)       -- wasm dyld doesn't track which symbol comes from which .so       ExtWasm {} -> lookupSymbol interp str -lookupClosure :: Interp -> String -> IO (Maybe HValueRef)+interpSymbolToCLabel :: forall s . InterpSymbol s -> FastString+interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is ->+  let+    n = interpSymbolName is+    suffix = interpSymbolSuffix is++    encodeZ = fastZStringToByteString . zEncodeFS+    (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of+        -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers+        -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.+        mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS+        mod -> mod+    packagePart = encodeZ (unitFS pkgKey)+    modulePart  = encodeZ (moduleNameFS modName)+    occPart     = encodeZ $ occNameMangledFS (nameOccName n)++    label = mconcat $+        [ packagePart `mappend` "_" | pkgKey /= mainUnit ]+        +++        [modulePart+        , "_"+        , occPart+        , "_"+        , fromString suffix+        ]+  in mkFastStringByteString label++lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef) lookupClosure interp str =-  interpCmd interp (LookupClosure str)+  interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))  -- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' -- which maps symbols to the address where they are loaded.@@ -488,7 +528,7 @@ -- a miss we run the action which determines the symbol's address and populate -- the cache with the answer. withSymbolCache :: Interp-                -> FastString+                -> InterpSymbol s                 -- ^ The symbol we are looking up in the cache                 -> IO (Maybe (Ptr ()))                 -- ^ An action which determines the address of the symbol we@@ -505,21 +545,19 @@   -- The analysis in #23415 further showed this cache should also benefit the   -- internal interpreter's loading times, and needn't be used by the external   -- interpreter only.-  cache <- readMVar (interpLookupSymbolCache interp)-  case lookupUFM cache str of-    Just p -> return (Just p)+  cached_val <- lookupInterpSymbolCache str (interpSymbolCache interp)+  case cached_val of+    Just {} -> return cached_val     Nothing -> do-       maddr <- determine_addr       case maddr of         Nothing -> return Nothing         Just p -> do-          let upd_cache cache' = addToUFM cache' str p-          modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache)-          return (Just p)+          updateInterpSymbolCache str (interpSymbolCache interp) p+          return maddr  purgeLookupSymbolCache :: Interp -> IO ()-purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM))+purgeLookupSymbolCache interp = purgeInterpSymbolCache (interpSymbolCache interp)  -- | loadDLL loads a dynamic library using the OS's native linker -- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either@@ -577,12 +615,11 @@   (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf)                                           []                                           (iservConfOpts    conf)-  lo_ref <- newIORef Nothing+  interpPipe <- mkPipeFromHandles rh wh   lock <- newMVar ()-  let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }   let process = InterpProcess                   { interpHandle = ph-                  , interpPipe   = pipe+                  , interpPipe                   , interpLock   = lock                   } @@ -690,40 +727,38 @@   ExternalInterp {}     -> throwIO (InstallationError "this operation requires -fno-external-interpreter") --- -------------------------------------------------------------------------------- Misc utils--fromEvalResult :: EvalResult a -> IO a-fromEvalResult (EvalException e) = throwIO (fromSerializableException e)-fromEvalResult (EvalSuccess a) = return a+--------------------------------------------------------------------------------+-- * Finding breakpoint information+-------------------------------------------------------------------------------- -getModBreaks :: HomeModInfo -> ModBreaks+-- | Get the breakpoint information from the ByteCode object associated to this+-- 'HomeModInfo'.+getModBreaks :: HomeModInfo -> Maybe InternalModBreaks getModBreaks hmi   | Just linkable <- homeModInfoByteCode hmi,     -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.     [cbc] <- linkableBCOs linkable-  = fromMaybe emptyModBreaks (bc_breaks cbc)+  = bc_breaks cbc   | otherwise-  = emptyModBreaks -- probably object code+  = Nothing -- probably object code --- | Interpreter uses Profiling way-interpreterProfiled :: Interp -> Bool-interpreterProfiled interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-  InternalInterp     -> hostIsProfiled-#endif-  ExternalInterp ext -> case ext of-    ExtIServ i -> iservConfProfiled (interpConfig i)-    ExtJS {}   -> False -- we don't support profiling yet in the JS backend-    ExtWasm i -> wasmInterpProfiled $ interpConfig i+-- | Read the 'InternalModBreaks' of the given home 'Module' (via+-- 'InternalBreakpointId') from the 'HomeUnitGraph'.+readIModBreaks :: HomeUnitGraph -> InternalBreakpointId -> IO InternalModBreaks+readIModBreaks hug ibi = expectJust <$> readIModBreaksMaybe hug (ibi_info_mod ibi) --- | Interpreter uses Dynamic way-interpreterDynamic :: Interp -> Bool-interpreterDynamic interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-  InternalInterp     -> hostIsDynamic-#endif-  ExternalInterp ext -> case ext of-    ExtIServ i -> iservConfDynamic (interpConfig i)-    ExtJS {}   -> False -- dynamic doesn't make sense for JS-    ExtWasm {} -> True  -- wasm dyld can only load dynamic code+-- | Read the 'InternalModBreaks' of the given home 'Module' from the 'HomeUnitGraph'.+readIModBreaksMaybe :: HomeUnitGraph -> Module -> IO (Maybe InternalModBreaks)+readIModBreaksMaybe hug mod = getModBreaks . expectJust <$> HUG.lookupHugByModule mod hug++-- | Read the 'ModBreaks' from the given module's 'InternalModBreaks'+readIModModBreaks :: HUG.HomeUnitGraph -> Module -> IO ModBreaks+readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaksMaybe hug mod++-- -----------------------------------------------------------------------------+-- Misc utils++fromEvalResult :: EvalResult a -> IO a+fromEvalResult (EvalException e) = throwIO (fromSerializableException e)+fromEvalResult (EvalSuccess a) = return a+
compiler/GHC/Runtime/Interpreter/JS.hs view
@@ -129,12 +129,11 @@                                            (nodeExtraArgs settings)   std_in <- readIORef interp_in -  lo_ref <- newIORef Nothing+  interpPipe <- mkPipeFromHandles rh wh   lock <- newMVar ()-  let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }   let proc = InterpProcess               { interpHandle = hdl-              , interpPipe   = pipe+              , interpPipe               , interpLock   = lock               }   pure (std_in, proc)@@ -166,7 +165,7 @@    -- get the unit-id of the ghci package. We need this to load the   -- interpreter code.-  ghci_unit_id <- case lookupPackageName (ue_units unit_env) (PackageName (fsLit "ghci")) of+  ghci_unit_id <- case lookupPackageName (ue_homeUnitState unit_env) (PackageName (fsLit "ghci")) of     Nothing -> cmdLineErrorIO "JS interpreter: couldn't find \"ghci\" package"     Just i  -> pure i @@ -228,9 +227,9 @@         , lcLinkCsources    = False -- we know that there are no C sources to load for the RTS         } -  -- link the RTS and its dependencies (things it uses from `base`, etc.)+  -- link the RTS and its dependencies (things it uses from `ghc-internal`, etc.)   let link_spec = LinkSpec-        { lks_unit_ids        = [rtsUnitId, ghcInternalUnitId, primUnitId]+        { lks_unit_ids        = [rtsUnitId, ghcInternalUnitId]         , lks_obj_root_filter = const False         , lks_extra_roots     = mempty         , lks_objs_hs         = mempty@@ -265,7 +264,7 @@   let ghci_unit_id = instGhciUnitId (instExtra inst)    -- compute unit dependencies of ghc_unit_id-  let unit_map = unitInfoMap (ue_units unit_env)+  let unit_map = unitInfoMap (ue_homeUnitState unit_env)   dep_units <- mayThrowUnitErr $ closeUnitDeps unit_map [(ghci_unit_id,Nothing)]   let units = dep_units ++ [ghci_unit_id] @@ -304,7 +303,7 @@         , lcLinkCsources    = True  -- enable C sources, if any         } -  let units = preloadUnits (ue_units unit_env)+  let units = preloadUnits (ue_homeUnitState unit_env)    -- compute dependencies   let link_spec = LinkSpec
compiler/GHC/Runtime/Interpreter/Wasm.hs view
@@ -10,13 +10,14 @@ #if !defined(mingw32_HOST_OS)  import Control.Concurrent.MVar-import Data.IORef+import Data.Maybe import GHC.Data.FastString import qualified GHC.Data.ShortText as ST import GHC.Platform import GHC.Unit import GHCi.Message import System.Directory+import System.Environment.Blank import System.IO import qualified System.Posix.IO as Posix import System.Process@@ -47,20 +48,29 @@   (rfd2, wfd2) <- Posix.createPipe   Posix.setFdOption rfd1 Posix.CloseOnExec True   Posix.setFdOption wfd2 Posix.CloseOnExec True+  ghc_env <- getEnvironment+  let dyld_env =+        [("GHCI_BROWSER", "1") | wasmInterpBrowser]+        ++ [("GHCI_BROWSER_HOST", wasmInterpBrowserHost), ("GHCI_BROWSER_PORT", show wasmInterpBrowserPort)]+        ++ [("GHCI_BROWSER_REDIRECT_WASI_CONSOLE", "1") | wasmInterpBrowserRedirectWasiConsole]+        ++ [("GHCI_BROWSER_PUPPETEER_LAUNCH_OPTS", f) | f <- maybeToList wasmInterpBrowserPuppeteerLaunchOpts]+        ++ [("GHCI_BROWSER_PLAYWRIGHT_BROWSER_TYPE", f) | f <- maybeToList wasmInterpBrowserPlaywrightBrowserType]+        ++ [("GHCI_BROWSER_PLAYWRIGHT_LAUNCH_OPTS", f) | f <- maybeToList wasmInterpBrowserPlaywrightLaunchOpts]+        ++ ghc_env   (_, _, _, ph) <-     createProcess       ( proc wasmInterpDyLD $           [wasmInterpLibDir, ghci_so_path, show wfd1, show rfd2]             ++ wasmInterpOpts             ++ ["+RTS", "-H64m", "-RTS"]-      )+      ) { env = Just dyld_env }   Posix.closeFd wfd1   Posix.closeFd rfd2   rh <- Posix.fdToHandle rfd1   wh <- Posix.fdToHandle wfd2   hSetBuffering wh NoBuffering   hSetBuffering rh NoBuffering-  lo_ref <- newIORef Nothing+  interpPipe <- mkPipeFromHandles rh wh   pending_frees <- newMVar []   lock <- newMVar ()   pure@@ -68,7 +78,7 @@       { instProcess =           InterpProcess             { interpHandle = ph,-              interpPipe = Pipe {pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref},+              interpPipe,               interpLock = lock             },         instPendingFrees = pending_frees,
compiler/GHC/Runtime/Loader.hs view
@@ -56,7 +56,6 @@ import GHC.Types.Unique.DFM  import GHC.Unit.Finder         ( findPluginModule, FindResult(..) )-import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) import GHC.Unit.Module   ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) ) import GHC.Unit.Module.ModIface@@ -215,7 +214,7 @@         ; case eith_plugin of             Left actual_type ->                 throwGhcExceptionIO (CmdLineError $-                    showSDocForUser dflags (ue_units (hsc_unit_env hsc_env))+                    showSDocForUser dflags (ue_homeUnitState (hsc_unit_env hsc_env))                       alwaysQualify $ hsep                           [ text "The value", ppr name                           , text "with type", ppr actual_type@@ -343,13 +342,8 @@                                 -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do     let dflags     = hsc_dflags hsc_env-    let fopts      = initFinderOpts dflags-    let fc         = hsc_FC hsc_env-    let unit_env   = hsc_unit_env hsc_env-    let unit_state = ue_units unit_env-    let mhome_unit = hsc_home_unit_maybe hsc_env     -- First find the unit the module resides in by searching exposed units and home modules-    found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name+    found_module <- findPluginModule hsc_env mod_name     case found_module of         Found _ mod -> do             -- Find the exports of the module@@ -360,7 +354,7 @@                 Just iface -> do                     -- Try and find the required name in the exports                     let decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod_name, is_pkg_qual = NoPkgQual-                                                , is_qual = False, is_dloc = noSrcSpan, is_isboot = NotBoot }+                                                , is_qual = False, is_dloc = noSrcSpan, is_isboot = NotBoot, is_level = SpliceLevel }                         imp_spec = ImpSpec decl_spec ImpAll                         env = mkGlobalRdrEnv                             $ gresFromAvails hsc_env (Just imp_spec) (mi_exports iface)
compiler/GHC/Settings/IO.hs view
@@ -19,6 +19,7 @@ import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir+import GHC.Unit.Types  import Control.Monad.Trans.Except import Control.Monad.IO.Class@@ -172,9 +173,10 @@   llvmTarget <- getSetting_raw "LLVM target"    -- We just assume on command line-  lc_prog <- getSetting "LLVM llc command"-  lo_prog <- getSetting "LLVM opt command"-  las_prog <- getSetting "LLVM llvm-as command"+  lc_prog <- getToolSetting "LLVM llc command"+  lo_prog <- getToolSetting "LLVM opt command"+  las_prog <- getToolSetting "LLVM llvm-as command"+  las_args <- map Option <$> getFlagsSetting "LLVM llvm-as flags"    let iserv_prog = libexec "ghc-iserv" @@ -182,6 +184,8 @@   ghcWithInterpreter <- getBooleanSetting "Use interpreter"   useLibFFI <- getBooleanSetting "Use LibFFI" +  baseUnitId <- getSetting_raw "base unit-id"+   return $ Settings     { sGhcNameVersion = GhcNameVersion       { ghcNameVersion_programName = "ghc"@@ -196,6 +200,11 @@       , fileSettings_globalPackageDatabase = globalpkgdb_path       } +    , sUnitSettings = UnitSettings+      {+        unitSettings_baseUnitId = stringToUnitId baseUnitId+      }+     , sToolSettings = ToolSettings       { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind       , toolSettings_ldSupportsFilelist      = ldSupportsFilelist@@ -225,7 +234,7 @@       , toolSettings_pgm_ranlib = ranlib_path       , toolSettings_pgm_lo  = (lo_prog,[])       , toolSettings_pgm_lc  = (lc_prog,[])-      , toolSettings_pgm_las = (las_prog, [])+      , toolSettings_pgm_las = (las_prog, las_args)       , toolSettings_pgm_i   = iserv_prog       , toolSettings_opt_L       = []       , toolSettings_opt_P       = []
compiler/GHC/Stg/BcPrep.hs view
@@ -49,7 +49,7 @@  bcPrepExpr :: StgExpr -> BcPrepM StgExpr -- explicitly match all constructors so we get a warning if we miss any-bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _ _) rhs)+bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)   | isLiftedTypeKind (typeKind tick_ty) = do       id <- newId tick_ty       rhs' <- bcPrepExpr rhs
compiler/GHC/Stg/CSE.hs view
@@ -142,6 +142,8 @@     foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)     filterTM f (SAM {sam_var = varm, sam_lit = litm}) =         SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm }+    mapMaybeTM f (SAM {sam_var = varm, sam_lit = litm}) =+        SAM { sam_var = mapMaybeTM f varm, sam_lit = mapMaybeTM f litm }  newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } @@ -158,6 +160,7 @@         m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }     foldTM k = un_cam >.> foldTM (foldTM k)     filterTM f = un_cam >.> fmap (filterTM f) >.> CAM+    mapMaybeTM f = un_cam >.> fmap (mapMaybeTM f) >.> CAM  ----------------- -- The CSE Env --
+ compiler/GHC/Stg/EnforceEpt.hs view
@@ -0,0 +1,750 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+ -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass++{-# OPTIONS_GHC -Wname-shadowing #-}+module GHC.Stg.EnforceEpt ( enforceEpt ) where++import GHC.Prelude hiding (id)++import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Types.Id+import GHC.Types.Id.Info (tagSigInfo)+import GHC.Types.Name+import GHC.Stg.Syntax+import GHC.Types.Basic ( CbvMark (..) )+import GHC.Types.Demand (isDeadEndAppSig)+import GHC.Types.Unique.Supply (mkSplitUniqSupply)+import GHC.Types.RepType (dataConRuntimeRepStrictness)+import GHC.Core (AltCon(..))+import Data.List (mapAccumL)+import GHC.Utils.Outputable+import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )++import GHC.Stg.EnforceEpt.Types+import GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds)+import Data.Maybe+import GHC.Types.Name.Env (mkNameEnv, NameEnv)+import GHC.Driver.DynFlags+import GHC.Utils.Logger+import qualified GHC.Unit.Types++{- Note [Evaluated and Properly Tagged]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A pointer is Evaluated and Properly Tagged (EPT) when the pointer++  (a) points directly to the value (not to an indirection, and not to a thunk)+  (b) is tagged with the tag corresponding to said value (e.g. constructor tag+      or arity of a function).++A binder is EPT when all the runtime pointers it binds are EPT.++Note that a lifted EPT pointer will never point to a thunk, nor will it be+tagged `000` (meaning "might be a thunk").++See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/rts/haskell-execution/pointer-tagging+for more information on pointer tagging.++Examples:+* Case binders are always EPT; hence an eval+    case x of x' { __DEFAULT -> ... }+  ensures that x' is EPT even if x was not.+* Data constructor bindings+    let x = Just y in ...+  are EPT: x will point to the heap-allocated constructor closure for (Just y),+  and the tag-bits of the pointer will encode the tag for Just (i.e. `010`).+* In practice, GHC also guarantees that strict fields (and others) are EPT;+  see Note [EPT enforcement].++Caveat:+Currently, the proper tag for builtin *unlifted* data types such as `Array#` is+not `001` but `000`, which is not a proper tag for lifted data.+This means that UnliftedRep is not a proper sub-rep of LiftedRep.+SG thinks it would be good to fix this; see #21792.++Note [EPT enforcement]+~~~~~~~~~~~~~~~~~~~~~~+The goal of EnforceEPT pass is to mark as many binders as possible as EPT+(see Note [Evaluated and Properly Tagged]).+To find more EPT binders, it establishes the following++EPT INVARIANT:+> Any binder of+>   * a strict field (see Note [Strict fields in Core]), or+>   * a CBV argument (see Note [CBV Function Ids])+> is EPT.++(Note that prior to EPT enforcement, this invariant may *not* always be upheld.+An example can be found at the end of this Note.)+This is all to optimise code such as the following:++  data SPair a b = SP !a !b+  case p :: SP Bool Bool of+    SP x y ->+      case x of+        True  -> ...+        False -> ...++We can infer that the strict field x is EPT and hence may safely+omit the code to enter x and the check for the presence of a tag that goes along+with it. However we still branch on the tag as usual to jump to the True or+False case.++Note that for every example involving strict fields we could find a similar+example using CBV functions, e.g.++  $wf x[EPT] y =+    case x of+      True  -> ...+      False -> ...++is the above example translated to use a CBV function $wf.+Note that /any/ strict function can in principle be chosen as a CBV function;+however, we presently only promote worker functions such as $wf to CBV because+we see all its call sites and can use the proper by-value calling convention.+More precisely, with -O0, we guarantee that no CBV functions are visible in+the interface file, so that naïve clients do not need to know how to call CBV+functions. See Note [CBV Function Ids] for more details.++Specification+-------------+EPT enforcement works like implicit type conversions in C, such as from int to+float, only much simpler (no overloaded operations such as +).+For EPT enforcement, the "type system" in question is whether a binder is+statically EPT. We differentiate "EPT binder" from "non-EPT binder", where the+latter means "might be EPT, but we could not prove it so".+In this sense, EPT binders form a subtype of non-EPT binders.+We differentiate two conversion directions:++  * Downcast: EPT binders can be converted into non-EPT binders for free.+  * Upcast: non-EPT binders can be converted into EPT binders by inserting an eval.++The EPT invariant expresses type signatures. In particular, these type+signatures entail two things:++  * A _precondition_: Any binder that is passed as a CBV arg/strict field+    must be EPT (i.e. must have type "EPT binder").+  * A _postcondition_: Any binder of a CBV arg/strict field is EPT.++EPT enforcement is then simply a matter of figuring out where to insert+Upcasts (remember that Downcasts are free).+Since Upcasts (evals!) are not free, it is desirable to insert as few as possible.+To this end, we run a static *EPT analysis*, the purpose of which is to identify+as many EPT binders as possible.+Beyond discovering case binders and value bindings, EPT analysis exploits the+type signatures provided by the EPT invariant, looks inside returned tuples and+does some limited amount of fixpointing.+Afterwards, the *EPT rewriter* inserts the actual evals realising Upcasts.++Implementation+--------------++* EPT analysis is implemented in GHC.Stg.EnforceEpt.inferTags.+  It attaches its result to /binders/, not occurrence sites.+* The EPT rewriter establishes the EPT invariant by inserting evals. That is, if+    (a) a binder x is used to+          * construct a strict field (`SP x y`), or+          * passed as a CBV argument (`$wf x`),+        and+    (b) x was not inferred EPT,+  then the EPT rewriter inserts an eval prior to the call, e.g.+    case x of x' { __ DEFAULT -> SP x' y }.+    case x of x' { __ DEFAULT -> $wf x' }.+  (Recall that the case binder x' is always EPT.)+  This is implemented in GHC.Stg.EnforceEpt.Rewrite.rewriteTopBinds.+  This pass also propagates the EPTness from binders to occurrences.+  It is sound to insert evals on strict fields (Note [Strict fields in Core]),+  and on CBV arguments as well (Note [CBV Function Ids]).+* We also export the EPTness of top level bindings to allow this optimisation+  to work across module boundaries.+  NB: The EPT Invariant *must* be upheld, regardless of the optimisation level;+  hence EPTness is practically part of the internal ABI of a strict data+  constructor or CBV function. Note [CBV Function Ids] contains the details.+* Finally, code generation skips the thunk check when branching on binders that+  are EPT. This is done by `cgExpr`/`cgCase` in the backend.++Evaluation+----------+EPT enforcement can have large impact on spine-strict tree data structure+performance. For containers the reduction in runtimes with this optimization+was as follows:++intmap-benchmarks:    89.30%+intset-benchmarks:    90.87%+map-benchmarks:       88.00%+sequence-benchmarks:  99.84%+set-benchmarks:       85.00%+set-operations-intmap:88.64%+set-operations-map:   74.23%+set-operations-set:   76.50%+lookupge-intmap:      89.57%+lookupge-map:         70.95%++With nofib being ~0.3% faster as well.++Note that EPT enforcement may cause regressions in rare cases.+For example consider this code:++  foo x = ...+    let c = StrictJust x+    in ...++When x cannot be inferred EPT, the rewriter transforms to++  foo x = ...+    let c = case x of x' -> StrictJust x'+    in ...++which allocates an additional thunk for `c` that returns the constructor.  Boo!++Note [EPT enforcement lowers strict constructor worker semantics]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Core, a saturated application of a strict constructor worker evaluates its+strict fields and thus is *not* a value; see Note [Strict fields in Core].+This is also the semantics of strict constructor workers in STG *before* EPT+enforcement (see Note [EPT enforcement])++However, after enforcing the EPT Invariant, all constructor workers can+effectively be lazy. That is, when actually generating code to allocate the+data constructor, the code generator does not need to evaluate the argument;+that has already been done by the EPT pass.++Thus for code-gen reasons (StgToX), all constructor workers are considered lazy+after EPT enforcement.++Note [Why isn't the EPT Invariant enforced during Core passes?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Recall the definition of the EPT Invariant from Note [EPT enforcement].+Why can't it be established as an invariant right while desugaring to Core?+The reason is that some Core optimisations, such as FloatOut, will drop or delay+evals whenever they think it useful and thus destroy the Invariant.  Example:++  data Set a = Tip | Bin !a (Set a) (Set a)++We start with++  thk = f ()+  g x = ...(case thk of xv -> Bin xv Tip Tip)...++So far so good; the argument to Bin (which is strict) is evaluated.+Now we do float-out. And in doing so we do a reverse binder-swap (see+Note [Binder-swap during float-out] in SetLevels) thus++  g x = ...(case thk of xv -> Bin thk Nil Nil)...++The goal of the reverse binder-swap is to allow more floating -- and+indeed it does! We float the Bin to top level:++  lvl = Bin thk Tip Tip+  g x = ...(case thk of xv -> lvl)...++Now you can see that the argument of Bin, namely thk, points to the+thunk, not to the value as it did before.++In short, although it may be rare, the output of Core optimisation passes+might destroy the EPT Invariant, hence we need to enforce the EPT invariant+*after* passes such as FloatOut.+-}++{- Note [TagInfo of functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The purpose of tag inference is really to figure out when we don't have to enter+value closures. There the meaning of the tag is fairly obvious.+For functions we never make use of the tag info so we have two choices:+* Treat them as TagDunno+* Treat them as TagProper (as they *are* tagged with their arity) and be really+  careful to make sure we still enter them when needed.+As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where+it made the code simpler. But besides implementation complexity there isn't any reason+why we couldn't be more rigorous in dealing with functions.++NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions.+So option two isn't really an option without reworking this anyway.++Note [EPT enforcement debugging]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a flag -dtag-inference-checks which inserts various+compile/runtime checks in order to ensure the EPT Invariant+holds. It should cover all places+where tags matter and disable optimizations which interfere with checking+the invariant like generation of AP-Thunks.++Note [Polymorphic StgPass for inferTagExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to reach a fixpoint we sometimes have to re-analyse an expression+multiple times. But after the initial run the Ast will be parameterized by+a different StgPass! To handle this a large part of the analysis is polymorphic+over the exact StgPass we are using. Which allows us to run the analysis on+the output of itself.++Note [EPT enforcement for interpreted code]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The bytecode interpreter has a different behaviour when it comes+to the tagging of binders in certain situations than the StgToCmm code generator.++a) Tags for let-bindings:++  When compiling a binding for a constructor like `let x = Just True`+  Whether `x` will be properly tagged depends on the backend.+  For the interpreter x points to a BCO which once+  evaluated returns a properly tagged pointer to the heap object.+  In the Cmm backend for the same binding we would allocate the constructor right+  away and x will immediately be represented by a tagged pointer.+  This means for interpreted code we can not assume let bound constructors are+  properly tagged. Hence we distinguish between targeting bytecode and native in+  the analysis.+  We make this differentiation in `mkLetSig` where we simply never assume+  lets are tagged when targeting bytecode.++b) When referencing ids from other modules the Cmm backend will try to put a+   proper tag on these references through various means. When doing analysis we+   usually predict these cases to improve precision of the analysis.+   But to my knowledge the bytecode generator makes no such attempts so we must+   not infer imported bindings as tagged.+   This is handled in GHC.Stg.EnforceEpt.Types.lookupInfo+++-}++{- *********************************************************************+*                                                                      *+                         EPT enforcement pass+*                                                                      *+********************************************************************* -}++enforceEpt :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)+enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do+    -- pprTraceM "enforceEpt for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode)+    -- Annotate binders with tag information.+    let (!stg_binds_w_tags) = {-# SCC "StgEptInfer" #-}+                                        inferTags for_bytecode stg_binds+    putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags)++    let export_tag_info = collectExportInfo stg_binds_w_tags++    -- Rewrite STG to uphold the strict field invariant+    us_t <- mkSplitUniqSupply 't'+    let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding]++    return (rewritten_binds,export_tag_info)++{- *********************************************************************+*                                                                      *+                         Main inference algorithm+*                                                                      *+********************************************************************* -}++type OutputableInferPass p = (Outputable (TagEnv p)+                              , Outputable (GenStgExpr p)+                              , Outputable (BinderP p)+                              , Outputable (GenStgRhs p))++-- | This constraint encodes the fact that no matter what pass+-- we use the Let/Closure extension points are the same as these for+-- 'InferTaggedBinders.+type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders+                    , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders+                    , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders)++inferTags :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders]+inferTags for_bytecode binds =+  -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $+  snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds)++-----------------------+inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen+                -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)+inferTagTopBind env (StgTopStringLit id bs)+  = (env, StgTopStringLit id bs)+inferTagTopBind env (StgTopLifted bind)+  = (env', StgTopLifted bind')+  where+    (env', bind') = inferTagBind env bind+++-- Why is this polymorphic over the StgPass? See Note [Polymorphic StgPass for inferTagExpr]+-----------------------+inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p)+  => TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)+inferTagExpr env (StgApp fun args)+  =  --pprTrace "inferTagExpr1"+      -- (ppr fun <+> ppr args $$ ppr info $$+      --  text "deadEndInfo:" <> ppr (isDeadEndId fun, idArity fun, length args)+      -- )+    (info, StgApp fun args)+  where+    !fun_arity = idArity fun+    info+         -- It's important that we check for bottoms before all else.+         -- See Note [Bottom functions are TagTagged] and #24806 for why.+         | isDeadEndAppSig (idDmdSig fun) (length args)+         = TagTagged++         | fun_arity == 0 -- Unknown arity => Thunk or unknown call+         = TagDunno++         | Just (TagSig res_info) <- tagSigInfo (idInfo fun)+         , fun_arity == length args  -- Saturated+         = res_info++         | Just (TagSig res_info) <- lookupSig env fun+         , fun_arity == length args  -- Saturated+         = res_info++         | otherwise+         = --pprTrace "inferAppUnknown" (ppr fun) $+           TagDunno++inferTagExpr env (StgConApp con cn args tys)+  = (inferConTag env con args, StgConApp con cn args tys)++inferTagExpr _ (StgLit l)+  = (TagTagged, StgLit l)++inferTagExpr env (StgTick tick body)+  = (info, StgTick tick body')+  where+    (info, body') = inferTagExpr env body++inferTagExpr _ (StgOpApp op args ty)+  -- Which primops guarantee to return a properly tagged value?+  -- Probably none, and that is the conservative assumption anyway.+  -- (And foreign calls definitely need not make promises.)+  = (TagDunno, StgOpApp op args ty)++inferTagExpr env (StgLet ext bind body)+  = (info, StgLet ext bind' body')+  where+    (env', bind') = inferTagBind env bind+    (info, body') = inferTagExpr env' body++inferTagExpr env (StgLetNoEscape ext bind body)+  = (info, StgLetNoEscape ext bind' body')+  where+    (env', bind') = inferTagBind env bind+    (info, body') = inferTagExpr env' body++inferTagExpr in_env (StgCase scrut bndr ty alts)+  -- Unboxed tuples get their info from the expression we scrutinise if any+  | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts+  , isUnboxedTupleDataCon con+  , Just infos <- scrut_infos bndrs+  , let bndrs' = zipWithEqual mk_bndr bndrs infos+        mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig)+        mk_bndr tup_bndr tup_info =+            --  pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $+            (getBinderId in_env tup_bndr, TagSig tup_info)+        -- no case binder in alt_env here, unboxed tuple binders are dead after unarise+        alt_env = extendSigEnv in_env bndrs'+        (info, rhs') = inferTagExpr alt_env rhs+  =+    -- pprTrace "inferCase1" (+    --   text "scrut:" <> ppr scrut $$+    --   text "bndr:" <> ppr bndr $$+    --   text "infos" <> ppr infos $$+    --   text "out_bndrs" <> ppr bndrs') $+    (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con+                                                           , alt_bndrs=bndrs'+                                                           , alt_rhs=rhs'}])++  | null alts -- Empty case, but I might just be paranoid.+  = -- pprTrace "inferCase2" empty $+    (TagDunno, StgCase scrut' bndr' ty [])+  -- More than one alternative OR non-TagTuple single alternative.+  | otherwise+  =+    let+        case_env = extendSigEnv in_env [bndr']++        (infos, alts')+          = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'})+                  | g@GenStgAlt{ alt_con = con+                               , alt_bndrs = bndrs+                               , alt_rhs   = rhs+                               } <- alts+                  , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs+                        (info, rhs') = inferTagExpr alt_env rhs+                  ]+        alt_info = foldr combineAltInfo TagTagged infos+    in ( alt_info, StgCase scrut' bndr' ty alts')+  where+    -- Single unboxed tuple alternative+    scrut_infos bndrs = case scrut_info of+      TagTagged -> Just $ replicate (length bndrs) TagProper+      TagTuple infos -> Just infos+      _ -> Nothing+    (scrut_info, scrut') = inferTagExpr in_env scrut+    bndr' = (getBinderId in_env bndr, TagSig TagProper)++-- Compute binder sigs based on the constructors strict fields.+-- NB: Not used if we have tuple info from the scrutinee.+addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders])+addAltBndrInfo env (DataAlt con) bndrs+  | not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)+  = (out_env, out_bndrs)+  where+    marks = dataConRuntimeRepStrictness con :: [StrictnessMark]+    out_bndrs = zipWith mk_bndr bndrs marks+    out_env = extendSigEnv env out_bndrs++    mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig))+    mk_bndr bndr mark+      | isUnliftedType (idType id) || isMarkedStrict mark+      = (id, TagSig TagProper)+      | otherwise+      = noSig env bndr+        where+          id = getBinderId env bndr++addAltBndrInfo env _ bndrs = (env, map (noSig env) bndrs)++-----------------------------+inferTagBind :: (OutputableInferPass p, InferExtEq p)+  => TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)+inferTagBind in_env (StgNonRec bndr rhs)+  =+    -- pprTrace "inferBindNonRec" (+    --   ppr bndr $$+    --   ppr (isDeadEndId id) $$+    --   ppr sig)+    (env', StgNonRec (id, out_sig) rhs')+  where+    id   = getBinderId in_env bndr+    (in_sig,rhs') = inferTagRhs id in_env rhs+    out_sig = mkLetSig in_env in_sig+    env' = extendSigEnv in_env [(id, out_sig)]++inferTagBind in_env (StgRec pairs)+  = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $+    (in_env { te_env = out_env }, StgRec pairs')+  where+    (bndrs, rhss)     = unzip pairs+    in_ids            = map (getBinderId in_env) bndrs+    init_sigs         = map (initSig) $ zip in_ids rhss+    (out_env, pairs') = go in_env init_sigs rhss++    go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q]+                 -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)])+    go go_env in_sigs go_rhss+      --   | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False+      --  = undefined+       | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss')+       | otherwise     = go env' out_sigs rhss'+       where+         in_bndrs = in_ids `zip` in_sigs+         out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive+         rhs_env = extendSigEnv go_env in_bndrs+         (out_sigs, rhss') = unzip (zipWithEqual anaRhs in_ids go_rhss)+         env' = makeTagged go_env++         anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)+         anaRhs bnd rhs =+            let (sig_rhs,rhs') = inferTagRhs bnd rhs_env rhs+            in (mkLetSig go_env sig_rhs, rhs')+++         updateBndr :: (Id,TagSig) -> (Id,TagSig)+         updateBndr (v,sig) = (setIdTagSig v sig, sig)++initSig :: forall p. (Id, GenStgRhs p) -> TagSig+-- Initial signature for the fixpoint loop+initSig (_bndr, StgRhsCon {})               = TagSig TagTagged+initSig (bndr, StgRhsClosure _ _ _ _ _ _) =+  fromMaybe defaultSig (idTagSig_maybe bndr)+  where defaultSig = (TagSig TagTagged)++{- Note [Bottom functions are TagTagged]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a function with two branches with one+being bottom, and the other returning a tagged+unboxed tuple what is the result? We give it TagTagged!+To answer why consider this function:++foo :: Bool -> (# Bool, Bool #)+foo x = case x of+    True -> (# True,True #)+    False -> undefined++The true branch is obviously tagged. The other branch isn't.+We want to treat the *result* of foo as tagged as well so that+the combination of the branches also is tagged if all non-bottom+branches are tagged.+This is safe because the function is still always called/entered as long+as it's applied to arguments. Since the function will never return we can give+it safely any tag sig we like.+So we give it TagTagged, as it allows the combined tag sig of the case expression+to be the combination of all non-bottoming branches.++NB: After the analysis is done we go back to treating bottoming functions as+untagged to ensure they are evaluated as expected in code like:++  case bottom_id of { ...}++-}++-----------------------------+inferTagRhs :: forall p.+     (OutputableInferPass p, InferExtEq p)+  => Id -- ^ Id we are binding to.+  -> TagEnv p -- ^+  -> GenStgRhs p -- ^+  -> (TagSig, GenStgRhs 'InferTaggedBinders)+inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body typ)+  | isDeadEndId bnd_id && (notNull) bndrs+  -- See Note [Bottom functions are TagTagged]+  = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body' typ)+  | otherwise+  = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $+    (TagSig info', StgRhsClosure ext cc upd out_bndrs body' typ)+  where+    out_bndrs+      | Just marks <- idCbvMarks_maybe bnd_id+      -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim+      -- the list of marks to the last strict entry. So we can conservatively+      -- assume these are not strict+      = zipWith (mkArgSig) bndrs (marks ++ repeat NotMarkedCbv)+      | otherwise = map (noSig env') bndrs :: [(Id,TagSig)]++    env' = extendSigEnv in_env out_bndrs+    (info, body') = inferTagExpr env' body+    info'+      -- It's a thunk+      | null bndrs+      = TagDunno+      -- TODO: We could preserve tuple fields for thunks+      -- as well. But likely not worth the complexity.++      | otherwise  = info++    mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig)+    mkArgSig bndp mark =+      let id = getBinderId in_env bndp+          tag = case mark of+            MarkedCbv -> TagProper+            _+              | isUnliftedType (idType id) -> TagProper+              | otherwise -> TagDunno+      in (id, TagSig tag)++inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args typ)+-- Constructors, which have untagged arguments to strict fields+-- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno+  = --pprTrace "inferTagRhsCon" (ppr grp_ids) $+    (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args typ)++-- Adjust let semantics to the targeted backend.+-- See Note [EPT enforcement for interpreted code]+mkLetSig :: TagEnv p -> TagSig -> TagSig+mkLetSig env in_sig+  | for_bytecode = TagSig TagDunno+  | otherwise = in_sig+  where+    for_bytecode = te_bytecode env++{- Note [Constructor TagSigs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+@inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor+or a StgConApp expression.+Usually these will simply be TagProper. But there are exceptions.+If any of the fields in the constructor are strict, but any argument to these+fields is not tagged then we will have to case on the argument before storing+in the constructor. Which means for let bindings the RHS turns into a thunk+which obviously is no longer properly tagged.+For example we might start with:++    let x<TagDunno> = f ...+    let c<TagProper> = StrictPair x True++But we know during the rewrite stage x will need to be evaluated in the RHS+of `c` so we will infer:++    let x<TagDunno> = f ...+    let c<TagDunno> = StrictPair x True++Which in the rewrite stage will then be rewritten into:++    let x<TagDunno> = f ...+    let c<TagDunno> = case x of x' -> StrictPair x' True++The other exception is unboxed tuples. These will get a TagTuple+signature with a list of TagInfo about their individual binders+as argument. As example:++    let c<TagProper> = True+    let x<TagDunno> = ...+    let f<?> z = case z of z'<TagProper> -> (# c, x #)++Here we will infer for f the Signature <TagTuple[TagProper,TagDunno]>.+This information will be used if we scrutinize a saturated application of+`f` in order to determine the taggedness of the result.+That is for `case f x of (# r1,r2 #) -> rhs` we can infer+r1<TagProper> and r2<TagDunno> which allows us to skip all tag checks on `r1`+in `rhs`.++Things get a bit more complicated with nesting:++    let closeFd<TagTuple[...]> = ...+    let f x = ...+        case x of+          _ -> Solo# closeFd++The "natural" signature for the Solo# branch in `f` would be <TagTuple[TagTuple[...]]>.+But we flatten this out to <TagTuple[TagDunno]> for the time being as it improves compile+time and there doesn't seem to huge benefit to doing differently.++  -}++-- See Note [Constructor TagSigs]+inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo+inferConTag env con args+  | isUnboxedTupleDataCon con+  = TagTuple $ map (flatten_arg_tag . lookupInfo env) args+  | otherwise =+    -- pprTrace "inferConTag"+    --   ( text "con:" <> ppr con $$+    --     text "args:" <> ppr args $$+    --     text "marks:" <> ppr (dataConRuntimeRepStrictness con) $$+    --     text "arg_info:" <> ppr (map (lookupInfo env) args) $$+    --     text "info:" <> ppr info) $+    info+  where+    info = if any arg_needs_eval strictArgs then TagDunno else TagProper+    strictArgs = zipEqual args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)])+    arg_needs_eval (arg,strict)+      -- lazy args+      | not (isMarkedStrict strict) = False+      | tag <- (lookupInfo env arg)+      -- banged args need to be tagged, or require eval+      = not (isTaggedInfo tag)++    flatten_arg_tag (TagTagged) = TagProper+    flatten_arg_tag (TagProper ) = TagProper+    flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs]+    flatten_arg_tag (TagDunno) = TagDunno+++collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig+collectExportInfo binds =+  mkNameEnv bndr_info+  where+    bndr_info = concatMap collect binds :: [(Name,TagSig)]++    collect (StgTopStringLit {}) = []+    collect (StgTopLifted bnd) =+      case bnd of+        StgNonRec (id,sig) _rhs+          | TagSig TagDunno <- sig -> []+          | otherwise -> [(idName id,sig)]+        StgRec bnds -> collectRec bnds++    collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)]+    collectRec [] = []+    collectRec (bnd:bnds)+      | (p,_rhs)  <- bnd+      , (id,sig) <- p+      , TagSig TagDunno <- sig+      = (idName id,sig) : collectRec bnds+      | otherwise = collectRec bnds
+ compiler/GHC/Stg/EnforceEpt/Rewrite.hs view
@@ -0,0 +1,562 @@++-- Copyright (c) 2019 Andreas Klebinger+--++{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE TypeFamilies               #-}++module GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds, rewriteOpApp)+where++import GHC.Prelude++import GHC.Builtin.PrimOps ( PrimOp(..) )+import GHC.Types.Basic     ( CbvMark (..), isMarkedCbv+                           , TopLevelFlag(..), isTopLevel )+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Unique.Supply+import GHC.Types.Unique.FM+import GHC.Types.RepType+import GHC.Types.Var.Set+import GHC.Unit.Types++import GHC.Core.DataCon+import GHC.Core            ( AltCon(..) )+import GHC.Core.Type++import GHC.StgToCmm.Types+import GHC.StgToCmm.Closure (importedIdLFInfo)++import GHC.Stg.Utils+import GHC.Stg.Syntax as StgSyn++import GHC.Data.Maybe+import GHC.Utils.Panic++import GHC.Utils.Outputable+import GHC.Utils.Monad.State.Strict+import GHC.Utils.Misc++import GHC.Stg.EnforceEpt.Types++import Control.Monad++newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) }+    deriving (Functor, Monad, Applicative)++------------------------------------------------------------+-- Add cases around strict fields where required.+------------------------------------------------------------+{-+The work of this pass is simple:+* We traverse the STG AST looking for constructor allocations.+* For all allocations we check if there are strict fields in the constructor.+* For any strict field we check if the argument is known to be properly tagged.+* If it's not known to be properly tagged, we wrap the whole thing in a case,+  which will force the argument before allocation.+This is described in detail in Note [Evaluated and Properly Tagged].++The only slight complication is that we have to make sure not to invalidate free+variable analysis in the process.++Note [Partially applied workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes we will get a function f of the form+    -- Arity 1+    f :: Dict a -> a -> b -> (c -> d)+    f dict a b = case dict of+        C m1 m2 -> m1 a b++Which will result in a W/W split along the lines of+    -- Arity 1+    f :: Dict a -> a -> b -> (c -> d)+    f dict a = case dict of+        C m1 m2 -> $wf m1 a b++    -- Arity 4+    $wf :: (a -> b -> d -> c) -> a -> b -> c -> d+    $wf m1 a b c = m1 a b c++It's notable that the worker is called *undersaturated* in the wrapper.+At runtime what happens is that the wrapper will allocate a PAP which+once fully applied will call the worker. And all is fine.++But what about a call by value function! Well the function returned by `f` would+be a unknown call, so we lose the ability to enforce the invariant that+cbv marked arguments from StictWorkerId's are actually properly tagged+as the annotations would be unavailable at the (unknown) call site.++The fix is easy. We eta-expand all calls to functions taking call-by-value+arguments during CorePrep just like we do with constructor allocations.++Note [Upholding free variable annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The code generator requires us to maintain exact information+about free variables about closures. Since we convert some+RHSs from constructor allocations to closures we have to provide+fvs of these closures. Not all constructor arguments will become+free variables. Only these which are not bound at the top level+have to be captured.+To facilitate this we keep track of a set of locally bound variables in+the current context which we then use to filter constructor arguments+when building the free variable list.+-}++--------------------------------+-- Utilities+--------------------------------++instance MonadUnique RM where+    getUniqueSupplyM = RM $ do+        (m, us, mod,lcls) <- get+        let (us1, us2) = splitUniqSupply us+        (put) (m,us2,mod,lcls)+        return us1++getMap :: RM (UniqFM Id TagSig)+getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get)++setMap :: (UniqFM Id TagSig) -> RM ()+setMap !m = RM $ do+    (_,us,mod,lcls) <- get+    put (m, us,mod,lcls)++getMod :: RM Module+getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get)++getFVs :: RM IdSet+getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get)++setFVs :: IdSet -> RM ()+setFVs !fvs = RM $ do+    (tag_map,us,mod,_lcls) <- get+    put (tag_map, us,mod,fvs)++-- Rewrite the RHS(s) while making the id and it's sig available+-- to determine if things are tagged/need to be captured as FV.+withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a+withBind top_flag (StgNonRec bnd _) cont = withBinder top_flag bnd cont+withBind top_flag (StgRec binds) cont = do+    let (bnds,_rhss) = unzip binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders])+    withBinders top_flag bnds cont++addTopBind :: GenStgBinding 'InferTaggedBinders -> RM ()+addTopBind (StgNonRec (id, tag) _) = do+    s <- getMap+    -- pprTraceM "AddBind" (ppr id)+    setMap $ addToUFM s id tag+    return ()+addTopBind (StgRec binds) = do+    let (bnds,_rhss) = unzip binds+    !s <- getMap+    -- pprTraceM "AddBinds" (ppr $ map fst bnds)+    setMap $! addListToUFM s bnds++withBinder :: TopLevelFlag ->  (Id, TagSig) -> RM a -> RM a+withBinder top_flag (id,sig) cont = do+    oldMap <- getMap+    setMap $ addToUFM oldMap id sig+    a <- if isTopLevel top_flag+            then cont+            else withLcl id cont+    setMap oldMap+    return a++withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a+withBinders TopLevel sigs cont = do+    oldMap <- getMap+    setMap $ addListToUFM oldMap sigs+    a <- cont+    setMap oldMap+    return a+withBinders NotTopLevel sigs cont = do+    oldMap <- getMap+    oldFvs <- getFVs+    setMap $ addListToUFM oldMap sigs+    setFVs $ extendVarSetList oldFvs (map fst sigs)+    a <- cont+    setMap oldMap+    setFVs oldFvs+    return a++-- | Compute the argument with the given set of ids treated as requiring capture+-- as free variables.+withClosureLcls :: DIdSet -> RM a -> RM a+withClosureLcls fvs act = do+    old_fvs <- getFVs+    let !fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs+    setFVs fvs'+    !r <- act+    setFVs old_fvs+    return r++-- | Compute the argument with the given id treated as requiring capture+-- as free variables in closures.+withLcl :: Id -> RM a -> RM a+withLcl fv act = do+    old_fvs <- getFVs+    let !fvs' = extendVarSet old_fvs fv+    setFVs fvs'+    !r <- act+    setFVs old_fvs+    return r++{- Note [Tag inference for interactive contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When compiling bytecode we call myCoreToStg to get STG code first.+myCoreToStg in turn calls out to stg2stg which runs the STG to STG+passes followed by free variables analysis and the tag inference pass including+its rewriting phase at the end.+Running tag inference is important as it upholds Note [Evaluated and Properly Tagged].+While code executed by GHCi doesn't take advantage of the SFI it can call into+compiled code which does. So it must still make sure that the SFI is upheld.+See also #21083 and #22042.++However there one important difference in code generation for GHCi and regular+compilation. When compiling an entire module (not a GHCi expression), we call+`stg2stg` on the entire module which allows us to build up a map which is guaranteed+to have an entry for every binder in the current module.+For non-interactive compilation the tag inference rewrite pass takes advantage+of this by building up a map from binders to their tag signatures.++When compiling a GHCi expression on the other hand we invoke stg2stg separately+for each expression on the prompt. This means in GHCi for a sequence of:+    > let x = True+    > let y = StrictJust x+We first run stg2stg for `[x = True]`. And then again for [y = StrictJust x]`.++While computing the tag signature for `y` during tag inference inferConTag will check+if `x` is already tagged by looking up the tagsig of `x` in the binder->signature mapping.+However since this mapping isn't persistent between stg2stg+invocations the lookup will fail. This isn't a correctness issue since it's always+safe to assume a binding isn't tagged and that's what we do in such cases.++However for non-interactive mode we *don't* want to do this. Since in non-interactive mode+we have all binders of the module available for each invocation we can expect the binder->signature+mapping to be complete and all lookups to succeed. This means in non-interactive contexts a failed lookup+indicates a bug in the tag inference implementation.+For this reason we assert that we are running in interactive mode if a lookup fails.+-}+isTagged :: Id -> RM Bool+isTagged v+    -- See Note [Bottom functions are TagTagged]+    | isDeadEndId v = pure False+    | otherwise = do+    this_mod <- getMod+    -- See Note [Tag inference for interactive contexts]+    let lookupDefault v = assertPpr (isInteractiveModule this_mod)+                                    (text "unknown Id:" <> ppr this_mod <+> ppr v)+                                    (TagSig TagDunno)+    case nameIsLocalOrFrom this_mod (idName v) of+        True+            | definitelyUnliftedType (idType v)+              -- NB: v might be the Id of a representation-polymorphic join point,+              -- so we shouldn't use isUnliftedType here. See T22212.+            -> return True+            | otherwise -> do -- Local binding+                !s <- getMap+                let !sig = lookupWithDefaultUFM s (lookupDefault v) v+                return $ case sig of+                    TagSig info ->+                        case info of+                            TagDunno -> False+                            TagProper -> True+                            TagTagged -> True+                            TagTuple _ -> True -- Consider unboxed tuples tagged.+        -- Imported+        False -> return $!+                -- Determine whether it is tagged from the LFInfo of the imported id.+                -- See Note [The LFInfo of Imported Ids]+                case importedIdLFInfo v of+                    -- Function, applied not entered.+                    LFReEntrant {}+                        -> True+                    -- Thunks need to be entered.+                    LFThunk {}+                        -> False+                    -- LFCon means we already know the tag, and it's tagged.+                    LFCon {}+                        -> True+                    LFUnknown {}+                        -> False+                    LFUnlifted {}+                        -> True+                    LFLetNoEscape {}+                    -- Shouldn't be possible. I don't think we can export letNoEscapes+                        -> True+++isArgTagged :: StgArg -> RM Bool+isArgTagged (StgLitArg _) = return True+isArgTagged (StgVarArg v) = isTagged v++mkLocalArgId :: Id -> RM Id+mkLocalArgId id = do+    !u <- getUniqueM+    return $! setIdUnique (localiseId id) u++---------------------------+-- Actual rewrite pass+---------------------------+++rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding]+rewriteTopBinds mod us binds =+    let doBinds = mapM rewriteTop binds++    in evalState (unRM doBinds) (mempty, us, mod, mempty)++rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding+rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s)+rewriteTop (StgTopLifted bind)   = do+    -- Top level bindings can, and must remain in scope+    addTopBind bind+    (StgTopLifted) <$!> (rewriteBinds TopLevel bind)++-- For top level binds, the wrapper is guaranteed to be `id`+rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding)+rewriteBinds _top_flag (StgNonRec v rhs) = do+        (!rhs) <-  rewriteRhs v rhs+        return $! (StgNonRec (fst v) rhs)+rewriteBinds top_flag b@(StgRec binds) =+    -- Bring sigs of binds into scope for all rhss+    withBind top_flag b $ do+        (rhss) <- mapM (uncurry rewriteRhs) binds+        return $! (mkRec rhss)+        where+            mkRec :: [TgStgRhs] -> TgStgBinding+            mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss)++-- Rewrite a RHS+rewriteRhs :: (Id,TagSig) -> InferStgRhs+           -> RM (TgStgRhs)+rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewriteRhs_ #-} do+    -- pprTraceM "rewriteRhs" (ppr _id)++    -- Look up the nodes representing the constructor arguments.+    fieldInfos <- mapM isArgTagged args++    -- Filter out non-strict fields.+    let strictFields =+            getStrictConArgs con (zip args fieldInfos) :: [(StgArg,Bool)] -- (nth-argument, tagInfo)+    -- Filter out already tagged arguments.+    let needsEval = map fst . --get the actual argument+                        filter (not . snd) $ -- Keep untagged (False) elements.+                        strictFields :: [StgArg]+    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]++    if (null evalArgs)+        then return $! (StgRhsCon ccs con cn ticks args typ)+        else do+            --assert not (isTaggedSig tagSig)+            -- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id++            -- At this point iff we have  possibly untagged arguments to strict fields+            -- we convert the RHS into a RhsClosure which will evaluate the arguments+            -- before allocating the constructor.+            let ty_stub = panic "mkSeqs shouldn't use the type arg"+            conExpr <- mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs ty_stub)++            fvs <- fvArgs args+            -- lcls <- getFVs+            -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)++            -- We mark the closure updatable to retain sharing in the case that+            -- conExpr is an infinite recursive data type. See #23783.+            return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ+rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do+    withBinders NotTopLevel args $+        withClosureLcls fvs $+            StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body <*> pure typ+        -- return (closure)++fvArgs :: [StgArg] -> RM DVarSet+fvArgs args = do+    fv_lcls <- getFVs+    -- pprTraceM "fvArgs" (text "args:" <> ppr args $$ text "lcls:" <> pprVarSet (fv_lcls) (braces . fsep . map ppr) )+    return $ mkDVarSet [ v | StgVarArg v <- args, elemVarSet v fv_lcls]++rewriteArgs :: [StgArg] -> RM [StgArg]+rewriteArgs = mapM rewriteArg+rewriteArg :: StgArg -> RM StgArg+rewriteArg (StgVarArg v) = StgVarArg <$!> rewriteId v+rewriteArg  (lit@StgLitArg{}) = return lit++rewriteId :: Id -> RM Id+rewriteId v = do+    !is_tagged <- isTagged v+    if is_tagged then return $! setIdTagSig v (TagSig TagProper)+                 else return v++rewriteExpr :: GenStgExpr 'InferTaggedBinders -> RM (GenStgExpr 'CodeGen)+rewriteExpr (e@StgCase {})            = rewriteCase e+rewriteExpr (e@StgLet {})             = rewriteLet e+rewriteExpr (e@StgLetNoEscape {})     = rewriteLetNoEscape e+rewriteExpr (StgTick t e)             = StgTick t <$!> rewriteExpr e+rewriteExpr e@(StgConApp {})          = rewriteConApp e+rewriteExpr e@(StgApp {})             = rewriteApp e+rewriteExpr (StgLit lit)              = return $! (StgLit lit)+rewriteExpr (StgOpApp op args res_ty) = (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty+++rewriteCase :: InferStgExpr -> RM TgStgExpr+rewriteCase (StgCase scrut bndr alt_type alts) =+    withBinder NotTopLevel bndr $+        pure StgCase <*>+            rewriteExpr scrut <*>+            rewriteId (fst bndr) <*>+            pure alt_type <*>+            mapM rewriteAlt alts++rewriteCase _ = panic "Impossible: nodeCase"++rewriteAlt :: InferStgAlt -> RM TgStgAlt+rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} =+    withBinders NotTopLevel bndrs $ do+        !rhs' <- rewriteExpr rhs+        return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'}++rewriteLet :: InferStgExpr -> RM TgStgExpr+rewriteLet (StgLet xt bind expr) = do+    (!bind') <- rewriteBinds NotTopLevel bind+    withBind NotTopLevel bind $ do+        -- pprTraceM "withBindLet" (ppr $ bindersOfX bind)+        !expr' <- rewriteExpr expr+        return $! (StgLet xt bind' expr')+rewriteLet _ = panic "Impossible"++rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr+rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do+    (!bind') <- rewriteBinds NotTopLevel bind+    withBind NotTopLevel bind $ do+        !expr' <- rewriteExpr expr+        return $! (StgLetNoEscape xt bind' expr')+rewriteLetNoEscape _ = panic "Impossible"++rewriteConApp :: InferStgExpr -> RM TgStgExpr+rewriteConApp (StgConApp con cn args tys) = do+    -- We check if the strict field arguments are already known to be tagged.+    -- If not we evaluate them first.+    fieldInfos <- mapM isArgTagged args+    let strictIndices = getStrictConArgs con (zip fieldInfos args) :: [(Bool, StgArg)]+    let needsEval = map snd . filter (not . fst) $ strictIndices :: [StgArg]+    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]+    if (not $ null evalArgs)+        then do+            -- pprTraceM "Creating conAppSeqs for " $ ppr nodeId <+> parens ( ppr evalArgs ) -- <+> parens ( ppr fieldInfos )+            mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs tys)+        else return $! (StgConApp con cn args tys)++rewriteConApp _ = panic "Impossible"++-- Special case: Atomic binders, usually in a case context like `case f of ...`.+rewriteApp :: InferStgExpr -> RM TgStgExpr+rewriteApp (StgApp f []) = do+    f' <- rewriteId f+    return $! StgApp f' []+rewriteApp (StgApp f args)+    -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False+    -- = undefined+    | Just marks <- idCbvMarks_maybe f+    , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks+    , any isMarkedCbv relevant_marks+    = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks)+      unliftArg relevant_marks++    where+      -- If the function expects any argument to be call-by-value ensure the argument is already+      -- evaluated.+      unliftArg relevant_marks = do+        argTags <- mapM isArgTagged args+        let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv)  argTags :: [(StgArg, CbvMark, Bool)]++            -- untagged cbv argument positions+            cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo+            cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id]+        mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args)++rewriteApp (StgApp f args) = return $ StgApp f args+rewriteApp _ = panic "Impossible"++{-+Note [Rewriting primop arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given an application `op# x y`, is it worth applying `rewriteArg` to+`x` and `y`?  All that will do will be to set the `tagSig` for that+occurrence of `x` and `y` to record whether it is evaluated and+properly tagged. For the vast majority of primops that's a waste of+time: the argument is an `Int#` or something.++But code generation for `seq#` and the `dataToTag#` ops /does/ consult that+tag, to statically avoid generating an eval.  All three do so via `cgIdApp`,+which in turn uses `getCallMethod` which looks at the `tagSig`.++So for these we should call `rewriteArgs`.++-}++rewriteOpApp :: InferStgExpr -> RM TgStgExpr+rewriteOpApp (StgOpApp op args res_ty) = case op of+  op@(StgPrimOp primOp)+    | primOp == DataToTagSmallOp || primOp == DataToTagLargeOp+    -- see Note [Rewriting primop arguments]+    -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty+  _ -> pure $! StgOpApp op args res_ty+rewriteOpApp _ = panic "Impossible"++-- `mkSeq` x x' e generates `case x of x' -> e`+-- We could also substitute x' for x in e but that's so rarely beneficial+-- that we don't bother.+mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr+mkSeq id bndr !expr =+    -- pprTrace "mkSeq" (ppr (id,bndr)) $+    let altTy = mkStgAltTypeFromStgAlts bndr alt+        alt   = [GenStgAlt {alt_con = DEFAULT, alt_bndrs = [], alt_rhs = expr}]+    in StgCase (StgApp id []) bndr altTy alt++-- `mkSeqs args vs mkExpr` will force all vs, and construct+-- an argument list args' where each v is replaced by it's evaluated+-- counterpart v'.+-- That is if we call `mkSeqs [StgVar x, StgLit l] [x] mkExpr` then+-- the result will be (case x of x' { _DEFAULT -> <mkExpr [StgVar x', StgLit l]>}+{-# INLINE mkSeqs #-} -- We inline to avoid allocating mkExpr+mkSeqs  :: [StgArg] -- ^ Original arguments+        -> [Id]     -- ^ var args to be evaluated ahead of time+        -> ([StgArg] -> TgStgExpr)+                    -- ^ Function that reconstructs the expressions when passed+                    -- the list of evaluated arguments.+        -> RM TgStgExpr+mkSeqs args untaggedIds mkExpr = do+    argMap <- mapM (\arg -> (arg,) <$> mkLocalArgId arg ) untaggedIds :: RM [(InId, OutId)]+    -- mapM_ (pprTraceM "Forcing strict args before allocation:" . ppr) argMap+    let taggedArgs :: [StgArg]+            = map   (\v -> case v of+                        StgVarArg v' -> StgVarArg $ fromMaybe v' $ lookup v' argMap+                        lit -> lit)+                    args++    let conBody = mkExpr taggedArgs+    let body = foldr (\(v,bndr) expr -> mkSeq v bndr expr) conBody argMap+    return $! body++-- Out of all arguments passed at runtime only return these ending up in a+-- strict field+getStrictConArgs :: Outputable a => DataCon -> [a] -> [a]+getStrictConArgs con args+    -- These are always lazy in their arguments.+    | isUnboxedTupleDataCon con = []+    | isUnboxedSumDataCon con = []+    -- For proper data cons we have to check.+    | otherwise =+        assertPpr   (length args == length (dataConRuntimeRepStrictness con))+                    (text "Mismatched con arg and con rep strictness lengths:" $$+                     text "Con" <> ppr con <+> text "is applied to" <+> ppr args $$+                     text "But seems to have arity" <> ppr (length repStrictness)) $+        [ arg | (arg,MarkedStrict)+                    <- zipEqual args+                                repStrictness]+        where+            repStrictness = (dataConRuntimeRepStrictness con)
+ compiler/GHC/Stg/EnforceEpt/Types.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++{-# LANGUAGE UndecidableInstances #-}+ -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen++module GHC.Stg.EnforceEpt.Types+    ( module GHC.Stg.EnforceEpt.Types+    , module TagSig)+where++import GHC.Prelude++import GHC.Core.DataCon+import GHC.Core.Type (isUnliftedType)+import GHC.Types.Id+import GHC.Stg.Syntax+import GHC.Stg.EnforceEpt.TagSig as TagSig+import GHC.Types.Var.Env+import GHC.Utils.Outputable+import GHC.Utils.Misc( zipWithEqual )+import GHC.Utils.Panic++import GHC.StgToCmm.Types++{- *********************************************************************+*                                                                      *+                         Supporting data types+*                                                                      *+********************************************************************* -}++type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders+type InferStgBinding    = GenStgBinding    'InferTaggedBinders+type InferStgExpr       = GenStgExpr       'InferTaggedBinders+type InferStgRhs        = GenStgRhs        'InferTaggedBinders+type InferStgAlt        = GenStgAlt        'InferTaggedBinders++combineAltInfo :: TagInfo -> TagInfo -> TagInfo+combineAltInfo TagDunno         _              = TagDunno+combineAltInfo _                TagDunno       = TagDunno+combineAltInfo (TagTuple {})    TagProper      = TagDunno  -- This can happen with rep-polymorphic result, see #26107+combineAltInfo TagProper       (TagTuple {})   = TagDunno  -- This can happen with rep-polymorphic result, see #26107+combineAltInfo TagProper        TagProper      = TagProper+combineAltInfo (TagTuple is1)  (TagTuple is2)  = TagTuple (zipWithEqual combineAltInfo is1 is2)+combineAltInfo (TagTagged)      ti             = ti+combineAltInfo ti               TagTagged      = ti++type TagSigEnv = IdEnv TagSig+data TagEnv p = TE { te_env :: TagSigEnv+                   , te_get :: BinderP p -> Id+                   , te_bytecode :: !Bool+                   }++instance Outputable (TagEnv p) where+    ppr te = for_txt <+> ppr (te_env te)+        where+            for_txt = if te_bytecode te+                then text "for_bytecode"+                else text "for_native"++getBinderId :: TagEnv p -> BinderP p -> Id+getBinderId = te_get++initEnv :: Bool -> TagEnv 'CodeGen+initEnv for_bytecode = TE { te_env = emptyVarEnv+             , te_get = \x -> x+             , te_bytecode = for_bytecode }++-- | Simple convert env to a env of the 'InferTaggedBinders pass+-- with no other changes.+makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders+makeTagged env = TE { te_env = te_env env+                    , te_get = fst+                    , te_bytecode = te_bytecode env }++noSig :: TagEnv p -> BinderP p -> (Id, TagSig)+noSig env bndr+  | isUnliftedType (idType var) = (var, TagSig TagProper)+  | otherwise = (var, TagSig TagDunno)+  where+    var = getBinderId env bndr++-- | Look up a sig in the given env+lookupSig :: TagEnv p -> Id -> Maybe TagSig+lookupSig env fun = lookupVarEnv (te_env env) fun++-- | Look up a sig in the env or derive it from information+-- in the arg itself.+lookupInfo :: TagEnv p -> StgArg -> TagInfo+lookupInfo env (StgVarArg var)+  -- Nullary data constructors like True, False+  | Just dc <- isDataConWorkId_maybe var+  , isNullaryRepDataCon dc+  , not for_bytecode+  = TagProper++  | isUnliftedType (idType var)+  = TagProper++  -- Variables in the environment.+  | Just (TagSig info) <- lookupVarEnv (te_env env) var+  = info++  | Just lf_info <- idLFInfo_maybe var+  , not for_bytecode+  =   case lf_info of+          -- Function, tagged (with arity)+          LFReEntrant {}+              -> TagProper+          -- Thunks need to be entered.+          LFThunk {}+              -> TagDunno+          -- Constructors, already tagged.+          LFCon {}+              -> TagProper+          LFUnknown {}+              -> TagDunno+          LFUnlifted {}+              -> TagProper+          -- Shouldn't be possible. I don't think we can export letNoEscapes+          LFLetNoEscape {} -> panic "LFLetNoEscape exported"++  | otherwise+  = TagDunno+  where+    for_bytecode = te_bytecode env++lookupInfo _ (StgLitArg {})+  = TagProper++isDunnoSig :: TagSig -> Bool+isDunnoSig (TagSig TagDunno) = True+isDunnoSig (TagSig TagProper) = False+isDunnoSig (TagSig TagTuple{}) = False+isDunnoSig (TagSig TagTagged{}) = False++isTaggedInfo :: TagInfo -> Bool+isTaggedInfo TagProper = True+isTaggedInfo TagTagged = True+isTaggedInfo _         = False++extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p+extendSigEnv env@(TE { te_env = sig_env }) bndrs+  = env { te_env = extendVarEnvList sig_env bndrs }
compiler/GHC/Stg/FVs.hs view
@@ -257,8 +257,8 @@       , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs       = (StgTick tick e', imp_fvs, top_fvs, lcl_fvs')         where-          tickish (Breakpoint _ _ ids _) = mkDVarSet ids-          tickish _                      = emptyDVarSet+          tickish (Breakpoint _ _ ids) = mkDVarSet ids+          tickish _                    = emptyDVarSet      go_bind dc bind body = (dc bind' body', imp_fvs, top_fvs, lcl_fvs)       where
− compiler/GHC/Stg/InferTags.hs 
@@ -1,675 +0,0 @@-{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}- -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass--{-# OPTIONS_GHC -Wname-shadowing #-}-module GHC.Stg.InferTags ( inferTags ) where--import GHC.Prelude hiding (id)--import GHC.Core.DataCon-import GHC.Core.Type-import GHC.Types.Id-import GHC.Types.Id.Info (tagSigInfo)-import GHC.Types.Name-import GHC.Stg.Syntax-import GHC.Types.Basic ( CbvMark (..) )-import GHC.Types.Demand (isDeadEndAppSig)-import GHC.Types.Unique.Supply (mkSplitUniqSupply)-import GHC.Types.RepType (dataConRuntimeRepStrictness)-import GHC.Core (AltCon(..))-import Data.List (mapAccumL)-import GHC.Utils.Outputable-import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )--import GHC.Stg.InferTags.Types-import GHC.Stg.InferTags.Rewrite (rewriteTopBinds)-import Data.Maybe-import GHC.Types.Name.Env (mkNameEnv, NameEnv)-import GHC.Driver.DynFlags-import GHC.Utils.Logger-import qualified GHC.Unit.Types--{- Note [Tag Inference]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The purpose of this pass is to attach to every binder a flag-to indicate whether or not it is "properly tagged".  A binder-is properly tagged if it is guaranteed:- - to point to a heap-allocated *value*- - and to have the tag of the value encoded in the pointer--For example-  let x = Just y in ...--Here x will be properly tagged: it will point to the heap-allocated-values for (Just y), and the tag-bits of the pointer will encode-the tag for Just so there is no need to re-enter the closure or even-check for the presence of tag bits. The impacts of this can be very large.--For containers the reduction in runtimes with this optimization was as follows:--intmap-benchmarks:    89.30%-intset-benchmarks:    90.87%-map-benchmarks:       88.00%-sequence-benchmarks:  99.84%-set-benchmarks:       85.00%-set-operations-intmap:88.64%-set-operations-map:   74.23%-set-operations-set:   76.50%-lookupge-intmap:      89.57%-lookupge-map:         70.95%--With nofib being ~0.3% faster as well.--See Note [Tag inference passes] for how we proceed to generate and use this information.--Note [Strict Field Invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As part of tag inference we introduce the Strict Field Invariant.-Which consists of us saying that:--* Pointers in strict fields must (a) point directly to the value, and-  (b) must be properly tagged.--For example, given-  data T = MkT ![Int]--the Strict Field Invariant guarantees that the first field of any `MkT` constructor-will either point directly to nil, or directly to a cons cell;-and will be tagged with `001` or `010` respectively.-It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk").-NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs.--This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids].--Why do we care? Because if we have code like:--case strictPair of-  SP x y ->-    case x of ...--It allows us to safely omit the code to enter x and the check-for the presence of a tag that goes along with it.-However we might still branch on the tag as usual.-See Note [Tag Inference] for how much impact this can have for-some code.--This is enforced by the code GHC.Stg.InferTags.Rewrite-where we:--* Look at all constructor allocations.-* Check if arguments to their strict fields are known to be properly tagged-* If not we convert `StrictJust x` into `case x of x' -> StrictJust x'`--This is usually very beneficial but can cause regressions in rare edge cases where-we fail to proof that x is properly tagged, or where it simply isn't.-See Note [How untagged pointers can end up in strict fields] for how the second case-can arise.--For a full example of the worst case consider this code:--foo ... = ...-  let c = StrictJust x-  in ...--Here we would rewrite `let c = StrictJust x` into `let c = case x of x' -> StrictJust x'`-However that is horrible! We end up allocating a thunk for `c` first, which only when-evaluated will allocate the constructor.--So we do our best to establish that `x` is already tagged (which it almost always is)-to avoid this cost. In my benchmarks I haven't seen any cases where this causes regressions.--Note that there are similar constraints around Note [CBV Function Ids].--Note [How untagged pointers can end up in strict fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  data Set a = Tip | Bin !a (Set a) (Set a)--We make a wrapper for Bin that evaluates its arguments-  $WBin x a b = case x of xv -> Bin xv a b-Here `xv` will always be evaluated and properly tagged, just as the-Strict Field Invariant requires.--But alas the Simplifier can destroy the invariant: see #15696.-We start with-  thk = f ()-  g x = ...(case thk of xv -> Bin xv Tip Tip)...--So far so good; the argument to Bin (which is strict) is evaluated.-Now we do float-out. And in doing so we do a reverse binder-swap (see-Note [Binder-swap during float-out] in SetLevels) thus--  g x = ...(case thk of xv -> Bin thk Nil Nil)...--The goal of the reverse binder-swap is to allow more floating -- and-indeed it does! We float the Bin to top level:--  lvl = Bin thk Tip Tip-  g x = ...(case thk of xv -> lvl)...--Now you can see that the argument of Bin, namely thk, points to the-thunk, not to the value as it did before.--In short, although it may be rare, the output of optimisation passes-cannot guarantee to obey the Strict Field Invariant. For this reason-we run tag inference. See Note [Tag inference passes].--Note [Tag inference passes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Tag inference proceeds in two passes:-* The first pass is an analysis to compute which binders are properly tagged.-  The result is then attached to /binders/.-  This is implemented by `inferTagsAnal` in GHC.Stg.InferTags-* The second pass walks over the AST checking if the Strict Field Invariant is upheld.-  See Note [Strict Field Invariant].-  If required this pass modifies the program to uphold this invariant.-  Tag information is also moved from /binders/ to /occurrences/ during this pass.-  This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`.-* Finally the code generation uses this information to skip the thunk check when branching on-  values. This is done by `cgExpr`/`cgCase` in the backend.--Last but not least we also export the tag sigs of top level bindings to allow this optimization- to work across module boundaries.--Note [TagInfo of functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-The purpose of tag inference is really to figure out when we don't have to enter-value closures. There the meaning of the tag is fairly obvious.-For functions we never make use of the tag info so we have two choices:-* Treat them as TagDunno-* Treat them as TagProper (as they *are* tagged with their arity) and be really-  careful to make sure we still enter them when needed.-As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where-it made the code simpler. But besides implementation complexity there isn't any reason-why we couldn't be more rigorous in dealing with functions.--NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions.-So option two isn't really an option without reworking this anyway.--Note [Tag inference debugging]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is a flag -dtag-inference-checks which inserts various-compile/runtime checks in order to ensure the Strict Field Invariant-holds. It should cover all places-where tags matter and disable optimizations which interfere with checking-the invariant like generation of AP-Thunks.--Note [Polymorphic StgPass for inferTagExpr]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In order to reach a fixpoint we sometimes have to re-analyse an expression-multiple times. But after the initial run the Ast will be parameterized by-a different StgPass! To handle this a large part of the analysis is polymorphic-over the exact StgPass we are using. Which allows us to run the analysis on-the output of itself.--Note [Tag inference for interpreted code]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The bytecode interpreter has a different behaviour when it comes-to the tagging of binders in certain situations than the StgToCmm code generator.--a) Tags for let-bindings:--  When compiling a binding for a constructor like `let x = Just True`-  Whether `x` will be properly tagged depends on the backend.-  For the interpreter x points to a BCO which once-  evaluated returns a properly tagged pointer to the heap object.-  In the Cmm backend for the same binding we would allocate the constructor right-  away and x will immediately be represented by a tagged pointer.-  This means for interpreted code we can not assume let bound constructors are-  properly tagged. Hence we distinguish between targeting bytecode and native in-  the analysis.-  We make this differentiation in `mkLetSig` where we simply never assume-  lets are tagged when targeting bytecode.--b) When referencing ids from other modules the Cmm backend will try to put a-   proper tag on these references through various means. When doing analysis we-   usually predict these cases to improve precision of the analysis.-   But to my knowledge the bytecode generator makes no such attempts so we must-   not infer imported bindings as tagged.-   This is handled in GHC.Stg.InferTags.Types.lookupInfo----}--{- *********************************************************************-*                                                                      *-                         Tag inference pass-*                                                                      *-********************************************************************* -}--inferTags :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)-inferTags ppr_opts !for_bytecode logger this_mod stg_binds = do-    -- pprTraceM "inferTags for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode)-    -- Annotate binders with tag information.-    let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}-                                        inferTagsAnal for_bytecode stg_binds-    putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags)--    let export_tag_info = collectExportInfo stg_binds_w_tags--    -- Rewrite STG to uphold the strict field invariant-    us_t <- mkSplitUniqSupply 't'-    let rewritten_binds = {-# SCC "StgTagRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding]--    return (rewritten_binds,export_tag_info)--{- *********************************************************************-*                                                                      *-                         Main inference algorithm-*                                                                      *-********************************************************************* -}--type OutputableInferPass p = (Outputable (TagEnv p)-                              , Outputable (GenStgExpr p)-                              , Outputable (BinderP p)-                              , Outputable (GenStgRhs p))---- | This constraint encodes the fact that no matter what pass--- we use the Let/Closure extension points are the same as these for--- 'InferTaggedBinders.-type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders-                    , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders-                    , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders)--inferTagsAnal :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders]-inferTagsAnal for_bytecode binds =-  -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $-  snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds)--------------------------inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen-                -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)-inferTagTopBind env (StgTopStringLit id bs)-  = (env, StgTopStringLit id bs)-inferTagTopBind env (StgTopLifted bind)-  = (env', StgTopLifted bind')-  where-    (env', bind') = inferTagBind env bind----- Why is this polymorphic over the StgPass? See Note [Polymorphic StgPass for inferTagExpr]-------------------------inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p)-  => TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)-inferTagExpr env (StgApp fun args)-  =  --pprTrace "inferTagExpr1"-      -- (ppr fun <+> ppr args $$ ppr info $$-      --  text "deadEndInfo:" <> ppr (isDeadEndId fun, idArity fun, length args)-      -- )-    (info, StgApp fun args)-  where-    !fun_arity = idArity fun-    info-         -- It's important that we check for bottoms before all else.-         -- See Note [Bottom functions are TagTagged] and #24806 for why.-         | isDeadEndAppSig (idDmdSig fun) (length args)-         = TagTagged--         | fun_arity == 0 -- Unknown arity => Thunk or unknown call-         = TagDunno--         | Just (TagSig res_info) <- tagSigInfo (idInfo fun)-         , fun_arity == length args  -- Saturated-         = res_info--         | Just (TagSig res_info) <- lookupSig env fun-         , fun_arity == length args  -- Saturated-         = res_info--         | otherwise-         = --pprTrace "inferAppUnknown" (ppr fun) $-           TagDunno--inferTagExpr env (StgConApp con cn args tys)-  = (inferConTag env con args, StgConApp con cn args tys)--inferTagExpr _ (StgLit l)-  = (TagTagged, StgLit l)--inferTagExpr env (StgTick tick body)-  = (info, StgTick tick body')-  where-    (info, body') = inferTagExpr env body--inferTagExpr _ (StgOpApp op args ty)-  -- Which primops guarantee to return a properly tagged value?-  -- Probably none, and that is the conservative assumption anyway.-  -- (And foreign calls definitely need not make promises.)-  = (TagDunno, StgOpApp op args ty)--inferTagExpr env (StgLet ext bind body)-  = (info, StgLet ext bind' body')-  where-    (env', bind') = inferTagBind env bind-    (info, body') = inferTagExpr env' body--inferTagExpr env (StgLetNoEscape ext bind body)-  = (info, StgLetNoEscape ext bind' body')-  where-    (env', bind') = inferTagBind env bind-    (info, body') = inferTagExpr env' body--inferTagExpr in_env (StgCase scrut bndr ty alts)-  -- Unboxed tuples get their info from the expression we scrutinise if any-  | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts-  , isUnboxedTupleDataCon con-  , Just infos <- scrut_infos bndrs-  , let bndrs' = zipWithEqual "inferTagExpr" mk_bndr bndrs infos-        mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig)-        mk_bndr tup_bndr tup_info =-            --  pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $-            (getBinderId in_env tup_bndr, TagSig tup_info)-        -- no case binder in alt_env here, unboxed tuple binders are dead after unarise-        alt_env = extendSigEnv in_env bndrs'-        (info, rhs') = inferTagExpr alt_env rhs-  =-    -- pprTrace "inferCase1" (-    --   text "scrut:" <> ppr scrut $$-    --   text "bndr:" <> ppr bndr $$-    --   text "infos" <> ppr infos $$-    --   text "out_bndrs" <> ppr bndrs') $-    (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con-                                                           , alt_bndrs=bndrs'-                                                           , alt_rhs=rhs'}])--  | null alts -- Empty case, but I might just be paranoid.-  = -- pprTrace "inferCase2" empty $-    (TagDunno, StgCase scrut' bndr' ty [])-  -- More than one alternative OR non-TagTuple single alternative.-  | otherwise-  =-    let-        case_env = extendSigEnv in_env [bndr']--        (infos, alts')-          = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'})-                  | g@GenStgAlt{ alt_con = con-                               , alt_bndrs = bndrs-                               , alt_rhs   = rhs-                               } <- alts-                  , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs-                        (info, rhs') = inferTagExpr alt_env rhs-                  ]-        alt_info = foldr combineAltInfo TagTagged infos-    in ( alt_info, StgCase scrut' bndr' ty alts')-  where-    -- Single unboxed tuple alternative-    scrut_infos bndrs = case scrut_info of-      TagTagged -> Just $ replicate (length bndrs) TagProper-      TagTuple infos -> Just infos-      _ -> Nothing-    (scrut_info, scrut') = inferTagExpr in_env scrut-    bndr' = (getBinderId in_env bndr, TagSig TagProper)---- Compute binder sigs based on the constructors strict fields.--- NB: Not used if we have tuple info from the scrutinee.-addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders])-addAltBndrInfo env (DataAlt con) bndrs-  | not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)-  = (out_env, out_bndrs)-  where-    marks = dataConRuntimeRepStrictness con :: [StrictnessMark]-    out_bndrs = zipWith mk_bndr bndrs marks-    out_env = extendSigEnv env out_bndrs--    mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig))-    mk_bndr bndr mark-      | isUnliftedType (idType id) || isMarkedStrict mark-      = (id, TagSig TagProper)-      | otherwise-      = noSig env bndr-        where-          id = getBinderId env bndr--addAltBndrInfo env _ bndrs = (env, map (noSig env) bndrs)--------------------------------inferTagBind :: (OutputableInferPass p, InferExtEq p)-  => TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)-inferTagBind in_env (StgNonRec bndr rhs)-  =-    -- pprTrace "inferBindNonRec" (-    --   ppr bndr $$-    --   ppr (isDeadEndId id) $$-    --   ppr sig)-    (env', StgNonRec (id, out_sig) rhs')-  where-    id   = getBinderId in_env bndr-    (in_sig,rhs') = inferTagRhs id in_env rhs-    out_sig = mkLetSig in_env in_sig-    env' = extendSigEnv in_env [(id, out_sig)]--inferTagBind in_env (StgRec pairs)-  = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $-    (in_env { te_env = out_env }, StgRec pairs')-  where-    (bndrs, rhss)     = unzip pairs-    in_ids            = map (getBinderId in_env) bndrs-    init_sigs         = map (initSig) $ zip in_ids rhss-    (out_env, pairs') = go in_env init_sigs rhss--    go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q]-                 -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)])-    go go_env in_sigs go_rhss-      --   | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False-      --  = undefined-       | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss')-       | otherwise     = go env' out_sigs rhss'-       where-         in_bndrs = in_ids `zip` in_sigs-         out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive-         rhs_env = extendSigEnv go_env in_bndrs-         (out_sigs, rhss') = unzip (zipWithEqual "inferTagBind" anaRhs in_ids go_rhss)-         env' = makeTagged go_env--         anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)-         anaRhs bnd rhs =-            let (sig_rhs,rhs') = inferTagRhs bnd rhs_env rhs-            in (mkLetSig go_env sig_rhs, rhs')---         updateBndr :: (Id,TagSig) -> (Id,TagSig)-         updateBndr (v,sig) = (setIdTagSig v sig, sig)--initSig :: forall p. (Id, GenStgRhs p) -> TagSig--- Initial signature for the fixpoint loop-initSig (_bndr, StgRhsCon {})               = TagSig TagTagged-initSig (bndr, StgRhsClosure _ _ _ _ _ _) =-  fromMaybe defaultSig (idTagSig_maybe bndr)-  where defaultSig = (TagSig TagTagged)--{- Note [Bottom functions are TagTagged]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have a function with two branches with one-being bottom, and the other returning a tagged-unboxed tuple what is the result? We give it TagTagged!-To answer why consider this function:--foo :: Bool -> (# Bool, Bool #)-foo x = case x of-    True -> (# True,True #)-    False -> undefined--The true branch is obviously tagged. The other branch isn't.-We want to treat the *result* of foo as tagged as well so that-the combination of the branches also is tagged if all non-bottom-branches are tagged.-This is safe because the function is still always called/entered as long-as it's applied to arguments. Since the function will never return we can give-it safely any tag sig we like.-So we give it TagTagged, as it allows the combined tag sig of the case expression-to be the combination of all non-bottoming branches.--NB: After the analysis is done we go back to treating bottoming functions as-untagged to ensure they are evaluated as expected in code like:--  case bottom_id of { ...}---}--------------------------------inferTagRhs :: forall p.-     (OutputableInferPass p, InferExtEq p)-  => Id -- ^ Id we are binding to.-  -> TagEnv p -- ^-  -> GenStgRhs p -- ^-  -> (TagSig, GenStgRhs 'InferTaggedBinders)-inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body typ)-  | isDeadEndId bnd_id && (notNull) bndrs-  -- See Note [Bottom functions are TagTagged]-  = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body' typ)-  | otherwise-  = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $-    (TagSig info', StgRhsClosure ext cc upd out_bndrs body' typ)-  where-    out_bndrs-      | Just marks <- idCbvMarks_maybe bnd_id-      -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim-      -- the list of marks to the last strict entry. So we can conservatively-      -- assume these are not strict-      = zipWith (mkArgSig) bndrs (marks ++ repeat NotMarkedCbv)-      | otherwise = map (noSig env') bndrs :: [(Id,TagSig)]--    env' = extendSigEnv in_env out_bndrs-    (info, body') = inferTagExpr env' body-    info'-      -- It's a thunk-      | null bndrs-      = TagDunno-      -- TODO: We could preserve tuple fields for thunks-      -- as well. But likely not worth the complexity.--      | otherwise  = info--    mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig)-    mkArgSig bndp mark =-      let id = getBinderId in_env bndp-          tag = case mark of-            MarkedCbv -> TagProper-            _-              | isUnliftedType (idType id) -> TagProper-              | otherwise -> TagDunno-      in (id, TagSig tag)--inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args typ)--- Constructors, which have untagged arguments to strict fields--- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno-  = --pprTrace "inferTagRhsCon" (ppr grp_ids) $-    (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args typ)---- Adjust let semantics to the targeted backend.--- See Note [Tag inference for interpreted code]-mkLetSig :: TagEnv p -> TagSig -> TagSig-mkLetSig env in_sig-  | for_bytecode = TagSig TagDunno-  | otherwise = in_sig-  where-    for_bytecode = te_bytecode env--{- Note [Constructor TagSigs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-@inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor-or a StgConApp expression.-Usually these will simply be TagProper. But there are exceptions.-If any of the fields in the constructor are strict, but any argument to these-fields is not tagged then we will have to case on the argument before storing-in the constructor. Which means for let bindings the RHS turns into a thunk-which obviously is no longer properly tagged.-For example we might start with:--    let x<TagDunno> = f ...-    let c<TagProper> = StrictPair x True--But we know during the rewrite stage x will need to be evaluated in the RHS-of `c` so we will infer:--    let x<TagDunno> = f ...-    let c<TagDunno> = StrictPair x True--Which in the rewrite stage will then be rewritten into:--    let x<TagDunno> = f ...-    let c<TagDunno> = case x of x' -> StrictPair x' True--The other exception is unboxed tuples. These will get a TagTuple-signature with a list of TagInfo about their individual binders-as argument. As example:--    let c<TagProper> = True-    let x<TagDunno> = ...-    let f<?> z = case z of z'<TagProper> -> (# c, x #)--Here we will infer for f the Signature <TagTuple[TagProper,TagDunno]>.-This information will be used if we scrutinize a saturated application of-`f` in order to determine the taggedness of the result.-That is for `case f x of (# r1,r2 #) -> rhs` we can infer-r1<TagProper> and r2<TagDunno> which allows us to skip all tag checks on `r1`-in `rhs`.--Things get a bit more complicated with nesting:--    let closeFd<TagTuple[...]> = ...-    let f x = ...-        case x of-          _ -> Solo# closeFd--The "natural" signature for the Solo# branch in `f` would be <TagTuple[TagTuple[...]]>.-But we flatten this out to <TagTuple[TagDunno]> for the time being as it improves compile-time and there doesn't seem to huge benefit to doing differently.--  -}---- See Note [Constructor TagSigs]-inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo-inferConTag env con args-  | isUnboxedTupleDataCon con-  = TagTuple $ map (flatten_arg_tag . lookupInfo env) args-  | otherwise =-    -- pprTrace "inferConTag"-    --   ( text "con:" <> ppr con $$-    --     text "args:" <> ppr args $$-    --     text "marks:" <> ppr (dataConRuntimeRepStrictness con) $$-    --     text "arg_info:" <> ppr (map (lookupInfo env) args) $$-    --     text "info:" <> ppr info) $-    info-  where-    info = if any arg_needs_eval strictArgs then TagDunno else TagProper-    strictArgs = zipEqual "inferTagRhs" args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)])-    arg_needs_eval (arg,strict)-      -- lazy args-      | not (isMarkedStrict strict) = False-      | tag <- (lookupInfo env arg)-      -- banged args need to be tagged, or require eval-      = not (isTaggedInfo tag)--    flatten_arg_tag (TagTagged) = TagProper-    flatten_arg_tag (TagProper ) = TagProper-    flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs]-    flatten_arg_tag (TagDunno) = TagDunno---collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig-collectExportInfo binds =-  mkNameEnv bndr_info-  where-    bndr_info = concatMap collect binds :: [(Name,TagSig)]--    collect (StgTopStringLit {}) = []-    collect (StgTopLifted bnd) =-      case bnd of-        StgNonRec (id,sig) _rhs-          | TagSig TagDunno <- sig -> []-          | otherwise -> [(idName id,sig)]-        StgRec bnds -> collectRec bnds--    collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)]-    collectRec [] = []-    collectRec (bnd:bnds)-      | (p,_rhs)  <- bnd-      , (id,sig) <- p-      , TagSig TagDunno <- sig-      = (idName id,sig) : collectRec bnds-      | otherwise = collectRec bnds
− compiler/GHC/Stg/InferTags/Rewrite.hs 
@@ -1,563 +0,0 @@---- Copyright (c) 2019 Andreas Klebinger-----{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE TypeFamilies               #-}--module GHC.Stg.InferTags.Rewrite (rewriteTopBinds, rewriteOpApp)-where--import GHC.Prelude--import GHC.Builtin.PrimOps ( PrimOp(..) )-import GHC.Types.Basic     ( CbvMark (..), isMarkedCbv-                           , TopLevelFlag(..), isTopLevel )-import GHC.Types.Id-import GHC.Types.Name-import GHC.Types.Unique.Supply-import GHC.Types.Unique.FM-import GHC.Types.RepType-import GHC.Types.Var.Set-import GHC.Unit.Types--import GHC.Core.DataCon-import GHC.Core            ( AltCon(..) )-import GHC.Core.Type--import GHC.StgToCmm.Types-import GHC.StgToCmm.Closure (importedIdLFInfo)--import GHC.Stg.Utils-import GHC.Stg.Syntax as StgSyn--import GHC.Data.Maybe-import GHC.Utils.Panic--import GHC.Utils.Outputable-import GHC.Utils.Monad.State.Strict-import GHC.Utils.Misc--import GHC.Stg.InferTags.Types--import Control.Monad--newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) }-    deriving (Functor, Monad, Applicative)----------------------------------------------------------------- Add cases around strict fields where required.--------------------------------------------------------------{--The work of this pass is simple:-* We traverse the STG AST looking for constructor allocations.-* For all allocations we check if there are strict fields in the constructor.-* For any strict field we check if the argument is known to be properly tagged.-* If it's not known to be properly tagged, we wrap the whole thing in a case,-  which will force the argument before allocation.-This is described in detail in Note [Strict Field Invariant].--The only slight complication is that we have to make sure not to invalidate free-variable analysis in the process.--Note [Partially applied workers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Sometimes we will get a function f of the form-    -- Arity 1-    f :: Dict a -> a -> b -> (c -> d)-    f dict a b = case dict of-        C m1 m2 -> m1 a b--Which will result in a W/W split along the lines of-    -- Arity 1-    f :: Dict a -> a -> b -> (c -> d)-    f dict a = case dict of-        C m1 m2 -> $wf m1 a b--    -- Arity 4-    $wf :: (a -> b -> d -> c) -> a -> b -> c -> d-    $wf m1 a b c = m1 a b c--It's notable that the worker is called *undersaturated* in the wrapper.-At runtime what happens is that the wrapper will allocate a PAP which-once fully applied will call the worker. And all is fine.--But what about a call by value function! Well the function returned by `f` would-be a unknown call, so we lose the ability to enforce the invariant that-cbv marked arguments from StictWorkerId's are actually properly tagged-as the annotations would be unavailable at the (unknown) call site.--The fix is easy. We eta-expand all calls to functions taking call-by-value-arguments during CorePrep just like we do with constructor allocations.--Note [Upholding free variable annotations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The code generator requires us to maintain exact information-about free variables about closures. Since we convert some-RHSs from constructor allocations to closures we have to provide-fvs of these closures. Not all constructor arguments will become-free variables. Only these which are not bound at the top level-have to be captured.-To facilitate this we keep track of a set of locally bound variables in-the current context which we then use to filter constructor arguments-when building the free variable list.--}------------------------------------- Utilities-----------------------------------instance MonadUnique RM where-    getUniqueSupplyM = RM $ do-        (m, us, mod,lcls) <- get-        let (us1, us2) = splitUniqSupply us-        (put) (m,us2,mod,lcls)-        return us1--getMap :: RM (UniqFM Id TagSig)-getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get)--setMap :: (UniqFM Id TagSig) -> RM ()-setMap !m = RM $ do-    (_,us,mod,lcls) <- get-    put (m, us,mod,lcls)--getMod :: RM Module-getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get)--getFVs :: RM IdSet-getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get)--setFVs :: IdSet -> RM ()-setFVs !fvs = RM $ do-    (tag_map,us,mod,_lcls) <- get-    put (tag_map, us,mod,fvs)---- Rewrite the RHS(s) while making the id and it's sig available--- to determine if things are tagged/need to be captured as FV.-withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a-withBind top_flag (StgNonRec bnd _) cont = withBinder top_flag bnd cont-withBind top_flag (StgRec binds) cont = do-    let (bnds,_rhss) = unzip binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders])-    withBinders top_flag bnds cont--addTopBind :: GenStgBinding 'InferTaggedBinders -> RM ()-addTopBind (StgNonRec (id, tag) _) = do-    s <- getMap-    -- pprTraceM "AddBind" (ppr id)-    setMap $ addToUFM s id tag-    return ()-addTopBind (StgRec binds) = do-    let (bnds,_rhss) = unzip binds-    !s <- getMap-    -- pprTraceM "AddBinds" (ppr $ map fst bnds)-    setMap $! addListToUFM s bnds--withBinder :: TopLevelFlag ->  (Id, TagSig) -> RM a -> RM a-withBinder top_flag (id,sig) cont = do-    oldMap <- getMap-    setMap $ addToUFM oldMap id sig-    a <- if isTopLevel top_flag-            then cont-            else withLcl id cont-    setMap oldMap-    return a--withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a-withBinders TopLevel sigs cont = do-    oldMap <- getMap-    setMap $ addListToUFM oldMap sigs-    a <- cont-    setMap oldMap-    return a-withBinders NotTopLevel sigs cont = do-    oldMap <- getMap-    oldFvs <- getFVs-    setMap $ addListToUFM oldMap sigs-    setFVs $ extendVarSetList oldFvs (map fst sigs)-    a <- cont-    setMap oldMap-    setFVs oldFvs-    return a---- | Compute the argument with the given set of ids treated as requiring capture--- as free variables.-withClosureLcls :: DIdSet -> RM a -> RM a-withClosureLcls fvs act = do-    old_fvs <- getFVs-    let !fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs-    setFVs fvs'-    !r <- act-    setFVs old_fvs-    return r---- | Compute the argument with the given id treated as requiring capture--- as free variables in closures.-withLcl :: Id -> RM a -> RM a-withLcl fv act = do-    old_fvs <- getFVs-    let !fvs' = extendVarSet old_fvs fv-    setFVs fvs'-    !r <- act-    setFVs old_fvs-    return r--{- Note [Tag inference for interactive contexts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When compiling bytecode we call myCoreToStg to get STG code first.-myCoreToStg in turn calls out to stg2stg which runs the STG to STG-passes followed by free variables analysis and the tag inference pass including-its rewriting phase at the end.-Running tag inference is important as it upholds Note [Strict Field Invariant].-While code executed by GHCi doesn't take advantage of the SFI it can call into-compiled code which does. So it must still make sure that the SFI is upheld.-See also #21083 and #22042.--However there one important difference in code generation for GHCi and regular-compilation. When compiling an entire module (not a GHCi expression), we call-`stg2stg` on the entire module which allows us to build up a map which is guaranteed-to have an entry for every binder in the current module.-For non-interactive compilation the tag inference rewrite pass takes advantage-of this by building up a map from binders to their tag signatures.--When compiling a GHCi expression on the other hand we invoke stg2stg separately-for each expression on the prompt. This means in GHCi for a sequence of:-    > let x = True-    > let y = StrictJust x-We first run stg2stg for `[x = True]`. And then again for [y = StrictJust x]`.--While computing the tag signature for `y` during tag inference inferConTag will check-if `x` is already tagged by looking up the tagsig of `x` in the binder->signature mapping.-However since this mapping isn't persistent between stg2stg-invocations the lookup will fail. This isn't a correctness issue since it's always-safe to assume a binding isn't tagged and that's what we do in such cases.--However for non-interactive mode we *don't* want to do this. Since in non-interactive mode-we have all binders of the module available for each invocation we can expect the binder->signature-mapping to be complete and all lookups to succeed. This means in non-interactive contexts a failed lookup-indicates a bug in the tag inference implementation.-For this reason we assert that we are running in interactive mode if a lookup fails.--}-isTagged :: Id -> RM Bool-isTagged v-    -- See Note [Bottom functions are TagTagged]-    | isDeadEndId v = pure False-    | otherwise = do-    this_mod <- getMod-    -- See Note [Tag inference for interactive contexts]-    let lookupDefault v = assertPpr (isInteractiveModule this_mod)-                                    (text "unknown Id:" <> ppr this_mod <+> ppr v)-                                    (TagSig TagDunno)-    case nameIsLocalOrFrom this_mod (idName v) of-        True-            | definitelyUnliftedType (idType v)-              -- NB: v might be the Id of a representation-polymorphic join point,-              -- so we shouldn't use isUnliftedType here. See T22212.-            -> return True-            | otherwise -> do -- Local binding-                !s <- getMap-                let !sig = lookupWithDefaultUFM s (lookupDefault v) v-                return $ case sig of-                    TagSig info ->-                        case info of-                            TagDunno -> False-                            TagProper -> True-                            TagTagged -> True-                            TagTuple _ -> True -- Consider unboxed tuples tagged.-        -- Imported-        False -> return $!-                -- Determine whether it is tagged from the LFInfo of the imported id.-                -- See Note [The LFInfo of Imported Ids]-                case importedIdLFInfo v of-                    -- Function, applied not entered.-                    LFReEntrant {}-                        -> True-                    -- Thunks need to be entered.-                    LFThunk {}-                        -> False-                    -- LFCon means we already know the tag, and it's tagged.-                    LFCon {}-                        -> True-                    LFUnknown {}-                        -> False-                    LFUnlifted {}-                        -> True-                    LFLetNoEscape {}-                    -- Shouldn't be possible. I don't think we can export letNoEscapes-                        -> True---isArgTagged :: StgArg -> RM Bool-isArgTagged (StgLitArg _) = return True-isArgTagged (StgVarArg v) = isTagged v--mkLocalArgId :: Id -> RM Id-mkLocalArgId id = do-    !u <- getUniqueM-    return $! setIdUnique (localiseId id) u-------------------------------- Actual rewrite pass-------------------------------rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding]-rewriteTopBinds mod us binds =-    let doBinds = mapM rewriteTop binds--    in evalState (unRM doBinds) (mempty, us, mod, mempty)--rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding-rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s)-rewriteTop (StgTopLifted bind)   = do-    -- Top level bindings can, and must remain in scope-    addTopBind bind-    (StgTopLifted) <$!> (rewriteBinds TopLevel bind)---- For top level binds, the wrapper is guaranteed to be `id`-rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding)-rewriteBinds _top_flag (StgNonRec v rhs) = do-        (!rhs) <-  rewriteRhs v rhs-        return $! (StgNonRec (fst v) rhs)-rewriteBinds top_flag b@(StgRec binds) =-    -- Bring sigs of binds into scope for all rhss-    withBind top_flag b $ do-        (rhss) <- mapM (uncurry rewriteRhs) binds-        return $! (mkRec rhss)-        where-            mkRec :: [TgStgRhs] -> TgStgBinding-            mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss)---- Rewrite a RHS-rewriteRhs :: (Id,TagSig) -> InferStgRhs-           -> RM (TgStgRhs)-rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewriteRhs_ #-} do-    -- pprTraceM "rewriteRhs" (ppr _id)--    -- Look up the nodes representing the constructor arguments.-    fieldInfos <- mapM isArgTagged args--    -- Filter out non-strict fields.-    let strictFields =-            getStrictConArgs con (zip args fieldInfos) :: [(StgArg,Bool)] -- (nth-argument, tagInfo)-    -- Filter out already tagged arguments.-    let needsEval = map fst . --get the actual argument-                        filter (not . snd) $ -- Keep untagged (False) elements.-                        strictFields :: [StgArg]-    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]--    if (null evalArgs)-        then return $! (StgRhsCon ccs con cn ticks args typ)-        else do-            --assert not (isTaggedSig tagSig)-            -- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id--            -- At this point iff we have  possibly untagged arguments to strict fields-            -- we convert the RHS into a RhsClosure which will evaluate the arguments-            -- before allocating the constructor.-            let ty_stub = panic "mkSeqs shouldn't use the type arg"-            conExpr <- mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs ty_stub)--            fvs <- fvArgs args-            -- lcls <- getFVs-            -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)--            -- We mark the closure updatable to retain sharing in the case that-            -- conExpr is an infinite recursive data type. See #23783.-            return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ-rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do-    withBinders NotTopLevel args $-        withClosureLcls fvs $-            StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body <*> pure typ-        -- return (closure)--fvArgs :: [StgArg] -> RM DVarSet-fvArgs args = do-    fv_lcls <- getFVs-    -- pprTraceM "fvArgs" (text "args:" <> ppr args $$ text "lcls:" <> pprVarSet (fv_lcls) (braces . fsep . map ppr) )-    return $ mkDVarSet [ v | StgVarArg v <- args, elemVarSet v fv_lcls]--rewriteArgs :: [StgArg] -> RM [StgArg]-rewriteArgs = mapM rewriteArg-rewriteArg :: StgArg -> RM StgArg-rewriteArg (StgVarArg v) = StgVarArg <$!> rewriteId v-rewriteArg  (lit@StgLitArg{}) = return lit--rewriteId :: Id -> RM Id-rewriteId v = do-    !is_tagged <- isTagged v-    if is_tagged then return $! setIdTagSig v (TagSig TagProper)-                 else return v--rewriteExpr :: GenStgExpr 'InferTaggedBinders -> RM (GenStgExpr 'CodeGen)-rewriteExpr (e@StgCase {})            = rewriteCase e-rewriteExpr (e@StgLet {})             = rewriteLet e-rewriteExpr (e@StgLetNoEscape {})     = rewriteLetNoEscape e-rewriteExpr (StgTick t e)             = StgTick t <$!> rewriteExpr e-rewriteExpr e@(StgConApp {})          = rewriteConApp e-rewriteExpr e@(StgApp {})             = rewriteApp e-rewriteExpr (StgLit lit)              = return $! (StgLit lit)-rewriteExpr (StgOpApp op args res_ty) = (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty---rewriteCase :: InferStgExpr -> RM TgStgExpr-rewriteCase (StgCase scrut bndr alt_type alts) =-    withBinder NotTopLevel bndr $-        pure StgCase <*>-            rewriteExpr scrut <*>-            rewriteId (fst bndr) <*>-            pure alt_type <*>-            mapM rewriteAlt alts--rewriteCase _ = panic "Impossible: nodeCase"--rewriteAlt :: InferStgAlt -> RM TgStgAlt-rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} =-    withBinders NotTopLevel bndrs $ do-        !rhs' <- rewriteExpr rhs-        return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'}--rewriteLet :: InferStgExpr -> RM TgStgExpr-rewriteLet (StgLet xt bind expr) = do-    (!bind') <- rewriteBinds NotTopLevel bind-    withBind NotTopLevel bind $ do-        -- pprTraceM "withBindLet" (ppr $ bindersOfX bind)-        !expr' <- rewriteExpr expr-        return $! (StgLet xt bind' expr')-rewriteLet _ = panic "Impossible"--rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr-rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do-    (!bind') <- rewriteBinds NotTopLevel bind-    withBind NotTopLevel bind $ do-        !expr' <- rewriteExpr expr-        return $! (StgLetNoEscape xt bind' expr')-rewriteLetNoEscape _ = panic "Impossible"--rewriteConApp :: InferStgExpr -> RM TgStgExpr-rewriteConApp (StgConApp con cn args tys) = do-    -- We check if the strict field arguments are already known to be tagged.-    -- If not we evaluate them first.-    fieldInfos <- mapM isArgTagged args-    let strictIndices = getStrictConArgs con (zip fieldInfos args) :: [(Bool, StgArg)]-    let needsEval = map snd . filter (not . fst) $ strictIndices :: [StgArg]-    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]-    if (not $ null evalArgs)-        then do-            -- pprTraceM "Creating conAppSeqs for " $ ppr nodeId <+> parens ( ppr evalArgs ) -- <+> parens ( ppr fieldInfos )-            mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs tys)-        else return $! (StgConApp con cn args tys)--rewriteConApp _ = panic "Impossible"---- Special case: Atomic binders, usually in a case context like `case f of ...`.-rewriteApp :: InferStgExpr -> RM TgStgExpr-rewriteApp (StgApp f []) = do-    f' <- rewriteId f-    return $! StgApp f' []-rewriteApp (StgApp f args)-    -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False-    -- = undefined-    | Just marks <- idCbvMarks_maybe f-    , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks-    , any isMarkedCbv relevant_marks-    = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks)-      unliftArg relevant_marks--    where-      -- If the function expects any argument to be call-by-value ensure the argument is already-      -- evaluated.-      unliftArg relevant_marks = do-        argTags <- mapM isArgTagged args-        let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv)  argTags :: [(StgArg, CbvMark, Bool)]--            -- untagged cbv argument positions-            cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo-            cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id]-        mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args)--rewriteApp (StgApp f args) = return $ StgApp f args-rewriteApp _ = panic "Impossible"--{--Note [Rewriting primop arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given an application `op# x y`, is it worth applying `rewriteArg` to-`x` and `y`?  All that will do will be to set the `tagSig` for that-occurrence of `x` and `y` to record whether it is evaluated and-properly tagged. For the vast majority of primops that's a waste of-time: the argument is an `Int#` or something.--But code generation for `seq#` and the `dataToTag#` ops /does/ consult that-tag, to statically avoid generating an eval.  All three do so via `cgIdApp`,-which in turn uses `getCallMethod` which looks at the `tagSig`.--So for these we should call `rewriteArgs`.---}--rewriteOpApp :: InferStgExpr -> RM TgStgExpr-rewriteOpApp (StgOpApp op args res_ty) = case op of-  op@(StgPrimOp primOp)-    | primOp == DataToTagSmallOp || primOp == DataToTagLargeOp-    -- see Note [Rewriting primop arguments]-    -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty-  _ -> pure $! StgOpApp op args res_ty-rewriteOpApp _ = panic "Impossible"---- `mkSeq` x x' e generates `case x of x' -> e`--- We could also substitute x' for x in e but that's so rarely beneficial--- that we don't bother.-mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr-mkSeq id bndr !expr =-    -- pprTrace "mkSeq" (ppr (id,bndr)) $-    let altTy = mkStgAltTypeFromStgAlts bndr alt-        alt   = [GenStgAlt {alt_con = DEFAULT, alt_bndrs = [], alt_rhs = expr}]-    in StgCase (StgApp id []) bndr altTy alt---- `mkSeqs args vs mkExpr` will force all vs, and construct--- an argument list args' where each v is replaced by it's evaluated--- counterpart v'.--- That is if we call `mkSeqs [StgVar x, StgLit l] [x] mkExpr` then--- the result will be (case x of x' { _DEFAULT -> <mkExpr [StgVar x', StgLit l]>}-{-# INLINE mkSeqs #-} -- We inline to avoid allocating mkExpr-mkSeqs  :: [StgArg] -- ^ Original arguments-        -> [Id]     -- ^ var args to be evaluated ahead of time-        -> ([StgArg] -> TgStgExpr)-                    -- ^ Function that reconstructs the expressions when passed-                    -- the list of evaluated arguments.-        -> RM TgStgExpr-mkSeqs args untaggedIds mkExpr = do-    argMap <- mapM (\arg -> (arg,) <$> mkLocalArgId arg ) untaggedIds :: RM [(InId, OutId)]-    -- mapM_ (pprTraceM "Forcing strict args before allocation:" . ppr) argMap-    let taggedArgs :: [StgArg]-            = map   (\v -> case v of-                        StgVarArg v' -> StgVarArg $ fromMaybe v' $ lookup v' argMap-                        lit -> lit)-                    args--    let conBody = mkExpr taggedArgs-    let body = foldr (\(v,bndr) expr -> mkSeq v bndr expr) conBody argMap-    return $! body---- Out of all arguments passed at runtime only return these ending up in a--- strict field-getStrictConArgs :: Outputable a => DataCon -> [a] -> [a]-getStrictConArgs con args-    -- These are always lazy in their arguments.-    | isUnboxedTupleDataCon con = []-    | isUnboxedSumDataCon con = []-    -- For proper data cons we have to check.-    | otherwise =-        assertPpr   (length args == length (dataConRuntimeRepStrictness con))-                    (text "Mismatched con arg and con rep strictness lengths:" $$-                     text "Con" <> ppr con <+> text "is applied to" <+> ppr args $$-                     text "But seems to have arity" <> ppr (length repStrictness)) $-        [ arg | (arg,MarkedStrict)-                    <- zipEqual "getStrictConArgs"-                                args-                                repStrictness]-        where-            repStrictness = (dataConRuntimeRepStrictness con)
− compiler/GHC/Stg/InferTags/Types.hs 
@@ -1,145 +0,0 @@-{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}--{-# LANGUAGE UndecidableInstances #-}- -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen--module GHC.Stg.InferTags.Types-    ( module GHC.Stg.InferTags.Types-    , module TagSig)-where--import GHC.Prelude--import GHC.Core.DataCon-import GHC.Core.Type (isUnliftedType)-import GHC.Types.Id-import GHC.Stg.Syntax-import GHC.Stg.InferTags.TagSig as TagSig-import GHC.Types.Var.Env-import GHC.Utils.Outputable-import GHC.Utils.Misc( zipWithEqual )-import GHC.Utils.Panic--import GHC.StgToCmm.Types--{- *********************************************************************-*                                                                      *-                         Supporting data types-*                                                                      *-********************************************************************* -}--type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders-type InferStgBinding    = GenStgBinding    'InferTaggedBinders-type InferStgExpr       = GenStgExpr       'InferTaggedBinders-type InferStgRhs        = GenStgRhs        'InferTaggedBinders-type InferStgAlt        = GenStgAlt        'InferTaggedBinders--combineAltInfo :: TagInfo -> TagInfo -> TagInfo-combineAltInfo TagDunno         _              = TagDunno-combineAltInfo _                TagDunno       = TagDunno-combineAltInfo (TagTuple {})    TagProper      = panic "Combining unboxed tuple with non-tuple result"-combineAltInfo TagProper       (TagTuple {})   = panic "Combining unboxed tuple with non-tuple result"-combineAltInfo TagProper        TagProper      = TagProper-combineAltInfo (TagTuple is1)  (TagTuple is2)  = TagTuple (zipWithEqual "combineAltInfo" combineAltInfo is1 is2)-combineAltInfo (TagTagged)      ti             = ti-combineAltInfo ti               TagTagged      = ti--type TagSigEnv = IdEnv TagSig-data TagEnv p = TE { te_env :: TagSigEnv-                   , te_get :: BinderP p -> Id-                   , te_bytecode :: !Bool-                   }--instance Outputable (TagEnv p) where-    ppr te = for_txt <+> ppr (te_env te)-        where-            for_txt = if te_bytecode te-                then text "for_bytecode"-                else text "for_native"--getBinderId :: TagEnv p -> BinderP p -> Id-getBinderId = te_get--initEnv :: Bool -> TagEnv 'CodeGen-initEnv for_bytecode = TE { te_env = emptyVarEnv-             , te_get = \x -> x-             , te_bytecode = for_bytecode }---- | Simple convert env to a env of the 'InferTaggedBinders pass--- with no other changes.-makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders-makeTagged env = TE { te_env = te_env env-                    , te_get = fst-                    , te_bytecode = te_bytecode env }--noSig :: TagEnv p -> BinderP p -> (Id, TagSig)-noSig env bndr-  | isUnliftedType (idType var) = (var, TagSig TagProper)-  | otherwise = (var, TagSig TagDunno)-  where-    var = getBinderId env bndr---- | Look up a sig in the given env-lookupSig :: TagEnv p -> Id -> Maybe TagSig-lookupSig env fun = lookupVarEnv (te_env env) fun---- | Look up a sig in the env or derive it from information--- in the arg itself.-lookupInfo :: TagEnv p -> StgArg -> TagInfo-lookupInfo env (StgVarArg var)-  -- Nullary data constructors like True, False-  | Just dc <- isDataConWorkId_maybe var-  , isNullaryRepDataCon dc-  , not for_bytecode-  = TagProper--  | isUnliftedType (idType var)-  = TagProper--  -- Variables in the environment.-  | Just (TagSig info) <- lookupVarEnv (te_env env) var-  = info--  | Just lf_info <- idLFInfo_maybe var-  , not for_bytecode-  =   case lf_info of-          -- Function, tagged (with arity)-          LFReEntrant {}-              -> TagProper-          -- Thunks need to be entered.-          LFThunk {}-              -> TagDunno-          -- Constructors, already tagged.-          LFCon {}-              -> TagProper-          LFUnknown {}-              -> TagDunno-          LFUnlifted {}-              -> TagProper-          -- Shouldn't be possible. I don't think we can export letNoEscapes-          LFLetNoEscape {} -> panic "LFLetNoEscape exported"--  | otherwise-  = TagDunno-  where-    for_bytecode = te_bytecode env--lookupInfo _ (StgLitArg {})-  = TagProper--isDunnoSig :: TagSig -> Bool-isDunnoSig (TagSig TagDunno) = True-isDunnoSig (TagSig TagProper) = False-isDunnoSig (TagSig TagTuple{}) = False-isDunnoSig (TagSig TagTagged{}) = False--isTaggedInfo :: TagInfo -> Bool-isTaggedInfo TagProper = True-isTaggedInfo TagTagged = True-isTaggedInfo _         = False--extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p-extendSigEnv env@(TE { te_env = sig_env }) bndrs-  = env { te_env = extendVarEnvList sig_env bndrs }
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -376,7 +376,7 @@       -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess       -- args are passed on the stack, which means slow memory accesses       args_spill_on_stack-        | Just n <- max_n_args = maximum (map n_args rhss) > n+        | Just n <- max_n_args = any (> n) (map n_args rhss)         | otherwise = False        -- We only perform the lift if allocations didn't increase.
compiler/GHC/Stg/Pipeline.hs view
@@ -43,8 +43,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader import GHC.Settings (Platform)-import GHC.Stg.InferTags (inferTags)-import GHC.Stg.InferTags.TagSig ( StgCgInfos )+import GHC.Stg.EnforceEpt (enforceEpt)+import GHC.Stg.EnforceEpt.TagSig ( StgCgInfos )  data StgPipelineOpts = StgPipelineOpts   { stgPipeline_phases      :: ![StgToDo]@@ -100,7 +100,7 @@           -- annotations (which is used by code generator to compute offsets into closures)         ; let (binds_sorted_with_fvs, imp_fvs) = unzip (depSortWithAnnotStgPgm this_mod binds')         -- See Note [Tag inference for interactive contexts]-        ; (cg_binds, cg_infos) <- inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs+        ; (cg_binds, cg_infos) <- enforceEpt (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs         ; stg_linter False "StgCodeGen" cg_binds         ; pure (zip cg_binds imp_fvs, cg_infos)    }
compiler/GHC/Stg/Unarise.hs view
@@ -928,7 +928,7 @@       layout'  = layoutUbxSum sum_slots field_slots        tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag))-      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)+      arg_idxs = IM.fromList (zipEqual layout' args0)        ((_idx,_idx_map,_us,wrapper),slot_args)         = assert (length arg_idxs <= length sum_slots ) $
compiler/GHC/StgToByteCode.hs view
@@ -1,15 +1,17 @@-+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE DerivingVia #-}  -- --  (c) The University of Glasgow 2002-2006 --  -- | GHC.StgToByteCode: Generate bytecode from STG-module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where+module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen ) where  import GHC.Prelude @@ -29,9 +31,7 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.Runtime.Interpreter import GHCi.FFI-import GHCi.RemoteTypes import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Types.Name@@ -42,6 +42,7 @@ import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Core.Type+import GHC.Core.Predicate( tyCoVarsOfTypesWellScoped ) import GHC.Core.TyCo.Compare (eqType) import GHC.Types.RepType import GHC.Core.DataCon@@ -56,31 +57,33 @@ import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate)+import GHC.CmmToAsm.Config (platformWordWidth) import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,                               addIdReps, addArgReps,                               assertNonVoidIds, assertNonVoidStgArgs ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)+import GHC.Runtime.Interpreter ( interpreterProfiled ) import GHC.Data.Bitmap import GHC.Data.FlatBag as FlatBag import GHC.Data.OrdList import GHC.Data.Maybe-import GHC.Types.Name.Env (mkNameEnv) import GHC.Types.Tickish import GHC.Types.SptEntry+import GHC.ByteCode.Breakpoints -import Data.List ( genericReplicate, genericLength, intersperse+import Data.List ( genericReplicate, intersperse                  , partition, scanl', sortBy, zip4, zip6 ) import Foreign hiding (shiftL, shiftR) import Control.Monad import Data.Char  import GHC.Unit.Module-import GHC.Unit.Home.ModInfo (lookupHpt) -import Data.Array import Data.Coerce (coerce)-import Data.ByteString (ByteString)+#if MIN_VERSION_rts(1,0,3)+import qualified Data.ByteString.Char8 as BS+#endif import Data.Map (Map) import Data.IntMap (IntMap) import qualified Data.Map as Map@@ -93,6 +96,11 @@ import qualified Data.IntSet as IntSet import GHC.CoreToIface +import Control.Monad.IO.Class+import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Monad.Trans.State  (StateT(..))+import Data.Bifunctor (Bifunctor(..))+ -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -113,27 +121,23 @@                 bnd <- binds                 case bnd of                   StgTopLifted bnd      -> [Right bnd]-                  StgTopStringLit b str -> [Left (b, str)]+                  StgTopStringLit b str -> [Left (getName b, str)]             flattenBind (StgNonRec b e) = [(b,e)]             flattenBind (StgRec bs)     = bs-        stringPtrs <- allocateTopStrings interp strings -        (BcM_State{..}, proto_bcos) <-+        (proto_bcos, BcM_State{..}) <-            runBc hsc_env this_mod mb_modBreaks $ do              let flattened_binds = concatMap flattenBind (reverse lifted_binds)              FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds -        when (notNull ffis)-             (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")-         putDumpFileMaybe logger Opt_D_dump_BCOs            "Proto-BCOs" FormatByteCode            (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos))) -        let mod_breaks = case modBreaks of+        let mod_breaks = case mb_modBreaks of              Nothing -> Nothing-             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }-        cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs mod_breaks spt_entries+             Just mb -> Just $ mkInternalModBreaks this_mod breakInfo mb+        cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries          -- Squash space leaks in the CompiledByteCode.  This is really         -- important, because when loading a set of modules into GHCi@@ -147,22 +151,8 @@    where dflags  = hsc_dflags hsc_env         logger  = hsc_logger hsc_env-        interp  = hscInterp hsc_env         profile = targetProfile dflags --- | see Note [Generating code for top-level string literal bindings]-allocateTopStrings-  :: Interp-  -> [(Id, ByteString)]-  -> IO AddrEnv-allocateTopStrings interp topStrings = do-  let !(bndrs, strings) = unzip topStrings-  ptrs <- interpCmd interp $ MallocStrings strings-  return $ mkNameEnv (zipWith mk_entry bndrs ptrs)-  where-    mk_entry bndr ptr = let nm = getName bndr-                        in (nm, (nm, AddrPtr ptr))- {- Note [Generating code for top-level string literal bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As described in Note [Compilation plan for top-level string literals]@@ -173,9 +163,9 @@ we deal with them:    1. Top-level string literal bindings are separated from the rest of-     the module. Memory for them is allocated immediately, via-     interpCmd, in allocateTopStrings, and the resulting AddrEnv is-     recorded in the bc_strs field of the CompiledByteCode result.+     the module. Memory is not allocated until bytecode link-time, the+     bc_strs field of the CompiledByteCode result records [(Name, ByteString)]+     directly.    2. When we encounter a reference to a top-level string literal, we      generate a PUSH_ADDR pseudo-instruction, which is assembled to@@ -236,28 +226,39 @@ -- Create a BCO and do a spot of peephole optimisation on the insns -- at the same time. mkProtoBCO-   :: Platform-   -> name+   ::+    Platform+   -> Maybe Module+        -- ^ Just cur_mod <=> label with @BCO_NAME@ instruction+        -- see Note [BCO_NAME]+   -> Name    -> BCInstrList    -> Either  [CgStgAlt] (CgStgRhs)                 -- ^ original expression; for debugging only    -> Int       -- ^ arity    -> WordOff   -- ^ bitmap size    -> [StgWord] -- ^ bitmap-   -> Bool      -- ^ True <=> is a return point, rather than a function-   -> [FFIInfo]-   -> ProtoBCO name-mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis+   -> Bool      -- ^ True <=> it's a case continuation, rather than a function+                -- See also Note [Case continuation BCOs].+   -> ProtoBCO Name+mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret    = ProtoBCO {         protoBCOName = nm,-        protoBCOInstrs = maybe_with_stack_check,+        protoBCOInstrs = maybe_add_bco_name $ maybe_add_stack_check peep_d,         protoBCOBitmap = bitmap,         protoBCOBitmapSize = fromIntegral bitmap_size,         protoBCOArity = arity,-        protoBCOExpr = origin,-        protoBCOFFIs = ffis+        protoBCOExpr = origin       }      where+#if MIN_VERSION_rts(1,0,3)+        maybe_add_bco_name instrs+          | Just cur_mod <- _add_bco_name =+              let str = BS.pack $ showSDocOneLine defaultSDocContext (pprFullNameWithUnique cur_mod nm)+              in BCO_NAME str : instrs+#endif+        maybe_add_bco_name instrs = instrs+         -- Overestimate the stack usage (in words) of this BCO,         -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit         -- stack check.  (The interpreter always does a stack check@@ -265,17 +266,17 @@         -- BCO anyway, so we only need to add an explicit one in the         -- (hopefully rare) cases when the (overestimated) stack use         -- exceeds iNTERP_STACK_CHECK_THRESH.-        maybe_with_stack_check-           | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = peep_d+        maybe_add_stack_check instrs+           | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = instrs                 -- don't do stack checks at return points,                 -- everything is aggregated up to the top BCO                 -- (which must be a function).                 -- That is, unless the stack usage is >= AP_STACK_SPLIM,                 -- see bug #1466.            | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH-           = STKCHECK stack_usage : peep_d+           = STKCHECK stack_usage : instrs            | otherwise-           = peep_d     -- the supposedly common case+           = instrs     -- the supposedly common case          -- We assume that this sum doesn't wrap         stack_usage = sum (map bciStackUse peep_d)@@ -308,6 +309,7 @@   | Just data_con <- isDataConWorkId_maybe id,     isNullaryRepDataCon data_con = do     platform <- profilePlatform <$> getProfile+    add_bco_name <- shouldAddBcoName         -- Special case for the worker of a nullary data con.         -- It'll look like this:        Nil = /\a -> Nil a         -- If we feed it into schemeR, we'll get@@ -315,8 +317,9 @@         -- because mkConAppCode treats nullary constructor applications         -- by just re-using the single top-level definition.  So         -- for the worker itself, we must allocate it directly.-    -- ioToBc (putStrLn $ "top level BCO")-    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P])+    -- liftIO (putStrLn $ "top level BCO")+    pure (mkProtoBCO platform add_bco_name+                       (getName id) (toOL [PACK data_con 0, RETURN P])                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})    | otherwise@@ -334,6 +337,9 @@ -- Park the resulting BCO in the monad.  Also requires the -- name of the variable to which this value was bound, -- so as to give the resulting BCO a name.+--+-- The resulting ProtoBCO expects the free variables and the function arguments+-- to be in the stack frame directly before it. schemeR :: [Id]                 -- Free vars of the RHS, ordered as they                                 -- will appear in the thunk.  Empty for                                 -- top-level things, which have no free vars.@@ -358,6 +364,7 @@     -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body)    = do+     add_bco_name <- shouldAddBcoName      profile <- getProfile      let          platform  = profilePlatform profile@@ -371,112 +378,58 @@          -- them unlike constructor fields.          szsb_args = map (wordsToBytes platform . idSizeW platform) all_args          sum_szsb_args  = sum szsb_args+         -- Make a stack offset for each argument or free var -- they should+         -- appear contiguous in the stack, in order.          p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))           -- make the arg bitmap          bits = argBits platform (reverse (map (idArgRep platform) all_args))-         bitmap_size = genericLength bits+         bitmap_size = strictGenericLength bits          bitmap = mkBitmap platform bits      body_code <- schemeER_wrk sum_szsb_args p_init body -     emitBc (mkProtoBCO platform nm body_code (Right original_body)+     pure (mkProtoBCO platform add_bco_name nm body_code (Right original_body)                  arity bitmap_size bitmap False{-not alts-})  -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList-schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do-  code <- schemeE d 0 p rhs-  hsc_env <- getHscEnv-  current_mod <- getCurrentModule-  mb_current_mod_breaks <- getCurrentModBreaks-  case mb_current_mod_breaks of-    -- if we're not generating ModBreaks for this module for some reason, we-    -- can't store breakpoint occurrence information.-    Nothing -> pure code-    Just current_mod_breaks -> case break_info hsc_env tick_mod current_mod mb_current_mod_breaks of-      Nothing -> pure code-      Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do-        platform <- profilePlatform <$> getProfile-        let idOffSets = getVarOffSets platform d p fvs-            ty_vars   = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)-            toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)-            toWord = fmap (\(i, wo) -> (i, fromIntegral wo))-            breakInfo  = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty+schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do+  platform <- profilePlatform <$> getProfile -        let info_mod_ptr = modBreaks_module current_mod_breaks-        infox <- newBreakInfo breakInfo+  -- When we find a tick we update the "last breakpoint location".+  -- We use it when constructing step-out BRK_FUNs in doCase+  -- See Note [Debugger: Stepout internal break locs]+  code <- withBreakTick bp $ schemeE d 0 p rhs -        let cc | Just interp <- hsc_interp hsc_env-              , interpreterProfiled interp-              = cc_arr ! tick_no-              | otherwise = toRemotePtr nullPtr+  -- As per Note [Stack layout when entering run_BCO], the breakpoint AP_STACK+  -- as we yield from the interpreter is headed by a stg_apply_interp + BCO to be a valid stack.+  -- Therefore, the var offsets are offset by 2 words+  let idOffSets = map (fmap (second (+2))) $+                  getVarOffSets platform d p fvs+      ty_vars   = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)+      toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)+      toWord = fmap (\(i, wo) -> (i, fromIntegral wo))+      breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty+                    (Right tick_id) -        let -- cast that checks that round-tripping through Word16 doesn't change the value-            toW16 x = let r = fromIntegral x :: Word16-                      in if fromIntegral r == x-                        then r-                        else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)-            breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc-        return $ breakInstr `consOL` code-schemeER_wrk d p rhs = schemeE d 0 p rhs+  mibi <- newBreakInfo breakInfo --- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module--- from which the breakpoint originates.--- These are stored in 'ModBreaks' as remote pointers in order to allow the BCOs--- to refer to pointers in GHCi's address space.--- They are initialized in 'GHC.HsToCore.Breakpoints.mkModBreaks', called by--- 'GHC.HsToCore.deSugar'.------ Breakpoints might be disabled because we're in TH, because--- @-fno-break-points@ was specified, or because a module was reloaded without--- reinitializing 'ModBreaks'.------ If the module stored in the breakpoint is the currently processed module, use--- the 'ModBreaks' from the state.--- If that is 'Nothing', consider breakpoints to be disabled and skip the--- instruction.------ If the breakpoint is inlined from another module, look it up in the home--- package table.--- If the module doesn't exist there, or its module pointer is null (which means--- that the 'ModBreaks' value is uninitialized), skip the instruction.-break_info ::-  HscEnv ->-  Module ->-  Module ->-  Maybe ModBreaks ->-  Maybe ModBreaks-break_info hsc_env mod current_mod current_mod_breaks-  | mod == current_mod-  = check_mod_ptr =<< current_mod_breaks-  | Just hp <- lookupHpt (hsc_HPT hsc_env) (moduleName mod)-  = check_mod_ptr (getModBreaks hp)-  | otherwise-  = Nothing-  where-    check_mod_ptr mb-      | mod_ptr <- modBreaks_module mb-      , fromRemotePtr mod_ptr /= nullPtr-      = Just mb-      | otherwise-      = Nothing+  return $ case mibi of+    Nothing  -> code+    Just ibi -> BRK_FUN ibi `consOL` code +schemeER_wrk d p rhs = schemeE d 0 p rhs++-- | Get the offset in words into this breakpoint's AP_STACK which contains the matching Id getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] getVarOffSets platform depth env = map getOffSet   where     getOffSet id = case lookupBCEnv_maybe id env of-        Nothing     -> Nothing-        Just offset ->-            -- michalt: I'm not entirely sure why we need the stack-            -- adjustment by 2 here. I initially thought that there's-            -- something off with getIdValFromApStack (the only user of this-            -- value), but it looks ok to me. My current hypothesis is that-            -- this "adjustment" is needed due to stack manipulation for-            -- BRK_FUN in Interpreter.c In any case, this is used only when-            -- we trigger a breakpoint.-            let !var_depth_ws = bytesToWords platform (depth - offset) + 2-            in Just (id, var_depth_ws)+      Nothing     -> Nothing+      Just offset ->+          let !var_depth_ws = bytesToWords platform (depth - offset)+          in Just (id, var_depth_ws)  fvsToEnv :: BCEnv -> CgStgRhs -> [Id] -- Takes the free variables of a right-hand side, and@@ -525,7 +478,7 @@              -- otherwise use RETURN_TUPLE with a tuple descriptor              nv_reps -> do                let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 id nv_reps-               tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)+                   tuple_bco = tupleBCO platform call_info args_offsets                return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL`                         PUSH_BCO tuple_bco `consOL`                         unitOL RETURN_TUPLE@@ -561,8 +514,7 @@  -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF.-schemeE-    :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList+schemeE :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x [])    | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)@@ -589,7 +541,7 @@      platform <- targetPlatform <$> getDynFlags      let (xs,rhss) = case binds of StgNonRec x rhs  -> ([x],[rhs])                                    StgRec xs_n_rhss -> unzip xs_n_rhss-         n_binds = genericLength xs+         n_binds = strictGenericLength xs           fvss  = map (fvsToEnv p') rhss @@ -598,16 +550,15 @@          sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss           -- the arity of each rhs-         arities = map (genericLength . fst . collect) rhss+         arities = map (strictGenericLength . fst . collect) rhss           -- This p', d' defn is safe because all the items being pushed          -- are ptrs, so all have size 1 word.  d' and p' reflect the stack          -- after the closures have been allocated in the heap (but not          -- filled in), and pointers to them parked on the stack.          offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform))-         p' = Map.insertList (zipE xs offsets) p+         p' = Map.insertList (zipEqual xs offsets) p          d' = d + wordsToBytes platform n_binds-         zipE = zipEqual "schemeE"           -- ToDo: don't build thunks for things with no free variables          build_thunk@@ -652,10 +603,9 @@      thunk_codes <- sequence compile_binds      return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) -schemeE _d _s _p (StgTick (Breakpoint _ bp_id _ _) _rhs)-   = panic ("schemeE: Breakpoint without let binding: " ++-            show bp_id ++-            " forgot to run bcPrep?")+schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs)+   = pprPanic "schemeE: Breakpoint without let binding:"+        (ppr bp_id <+> text "forgot to run bcPrep?")  -- ignore other kinds of tick schemeE d s p (StgTick _ rhs) = schemeE d s p rhs@@ -714,8 +664,14 @@       then generateCCall d s p ccall_spec result_ty args       else unsupportedCConvException -schemeT d s p (StgOpApp (StgPrimOp op) args _ty)-   = doTailCall d s p (primOpId op) (reverse args)+schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = do+  profile <- getProfile+  let platform = profilePlatform profile+  case doPrimOp platform op d s p args of+    -- Can we do this right in the interpreter?+    Just prim_code -> prim_code+    -- Otherwise we have to do a call to the primop wrapper instead :(+    _         -> doTailCall d s p (primOpId op) (reverse args)  schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty)    = generatePrimCall d s p label (Just unit) result_ty args@@ -786,7 +742,10 @@     -> BcM BCInstrList doTailCall init_d s p fn args = do    platform <- profilePlatform <$> getProfile++   -- Do tail call only after    do_pushes init_d args (map (atomRep platform) args)+   where   do_pushes !d [] reps = do         assert (null reps) return ()@@ -810,6 +769,300 @@     (final_d, more_push_code) <- push_seq (d + sz) args     return (final_d, push_code `appOL` more_push_code) +doPrimOp  :: Platform+          -> PrimOp+          -> StackDepth+          -> Sequel+          -> BCEnv+          -> [StgArg]+          -> Maybe (BcM BCInstrList)+doPrimOp platform op init_d s p args =+  case op of+    IntAddOp -> sizedPrimOp OP_ADD+    Int64AddOp -> only64bit $ sizedPrimOp OP_ADD+    Int32AddOp -> sizedPrimOp OP_ADD+    Int16AddOp -> sizedPrimOp OP_ADD+    Int8AddOp -> sizedPrimOp OP_ADD+    WordAddOp -> sizedPrimOp OP_ADD+    Word64AddOp -> only64bit $ sizedPrimOp OP_ADD+    Word32AddOp -> sizedPrimOp OP_ADD+    Word16AddOp -> sizedPrimOp OP_ADD+    Word8AddOp -> sizedPrimOp OP_ADD+    AddrAddOp -> sizedPrimOp OP_ADD++    IntMulOp -> sizedPrimOp OP_MUL+    Int64MulOp -> only64bit $ sizedPrimOp OP_MUL+    Int32MulOp -> sizedPrimOp OP_MUL+    Int16MulOp -> sizedPrimOp OP_MUL+    Int8MulOp -> sizedPrimOp OP_MUL+    WordMulOp -> sizedPrimOp OP_MUL+    Word64MulOp -> only64bit $ sizedPrimOp OP_MUL+    Word32MulOp -> sizedPrimOp OP_MUL+    Word16MulOp -> sizedPrimOp OP_MUL+    Word8MulOp -> sizedPrimOp OP_MUL++    IntSubOp -> sizedPrimOp OP_SUB+    WordSubOp -> sizedPrimOp OP_SUB+    Int64SubOp -> only64bit $ sizedPrimOp OP_SUB+    Int32SubOp -> sizedPrimOp OP_SUB+    Int16SubOp -> sizedPrimOp OP_SUB+    Int8SubOp -> sizedPrimOp OP_SUB+    Word64SubOp -> only64bit $ sizedPrimOp OP_SUB+    Word32SubOp -> sizedPrimOp OP_SUB+    Word16SubOp -> sizedPrimOp OP_SUB+    Word8SubOp -> sizedPrimOp OP_SUB+    AddrSubOp -> sizedPrimOp OP_SUB++    IntAndOp -> sizedPrimOp OP_AND+    WordAndOp -> sizedPrimOp OP_AND+    Word64AndOp -> only64bit $ sizedPrimOp OP_AND+    Word32AndOp -> sizedPrimOp OP_AND+    Word16AndOp -> sizedPrimOp OP_AND+    Word8AndOp -> sizedPrimOp OP_AND++    IntNotOp -> sizedPrimOp OP_NOT+    WordNotOp -> sizedPrimOp OP_NOT+    Word64NotOp -> only64bit $ sizedPrimOp OP_NOT+    Word32NotOp -> sizedPrimOp OP_NOT+    Word16NotOp -> sizedPrimOp OP_NOT+    Word8NotOp -> sizedPrimOp OP_NOT++    IntXorOp -> sizedPrimOp OP_XOR+    WordXorOp -> sizedPrimOp OP_XOR+    Word64XorOp -> only64bit $ sizedPrimOp OP_XOR+    Word32XorOp -> sizedPrimOp OP_XOR+    Word16XorOp -> sizedPrimOp OP_XOR+    Word8XorOp -> sizedPrimOp OP_XOR++    IntOrOp -> sizedPrimOp OP_OR+    WordOrOp -> sizedPrimOp OP_OR+    Word64OrOp -> only64bit $ sizedPrimOp OP_OR+    Word32OrOp -> sizedPrimOp OP_OR+    Word16OrOp -> sizedPrimOp OP_OR+    Word8OrOp -> sizedPrimOp OP_OR++    WordSllOp   -> sizedPrimOp OP_SHL+    Word64SllOp -> only64bit $ sizedPrimOp OP_SHL -- check 32bit platform+    Word32SllOp -> sizedPrimOp OP_SHL+    Word16SllOp -> sizedPrimOp OP_SHL+    Word8SllOp -> sizedPrimOp OP_SHL+    IntSllOp    -> sizedPrimOp OP_SHL+    Int64SllOp  -> only64bit $ sizedPrimOp OP_SHL+    Int32SllOp  -> sizedPrimOp OP_SHL+    Int16SllOp  -> sizedPrimOp OP_SHL+    Int8SllOp  -> sizedPrimOp OP_SHL++    WordSrlOp   -> sizedPrimOp OP_LSR+    Word64SrlOp -> only64bit $ sizedPrimOp OP_LSR+    Word32SrlOp -> sizedPrimOp OP_LSR+    Word16SrlOp -> sizedPrimOp OP_LSR+    Word8SrlOp -> sizedPrimOp OP_LSR+    IntSrlOp    -> sizedPrimOp OP_LSR+    Int64SrlOp  -> only64bit $ sizedPrimOp OP_LSR -- check 32bit platform+    Int32SrlOp  -> sizedPrimOp OP_LSR+    Int16SrlOp  -> sizedPrimOp OP_LSR+    Int8SrlOp  -> sizedPrimOp OP_LSR++    IntSraOp -> sizedPrimOp OP_ASR+    Int64SraOp -> only64bit $ sizedPrimOp OP_ASR -- check 32bit platform+    Int32SraOp -> sizedPrimOp OP_ASR+    Int16SraOp -> sizedPrimOp OP_ASR+    Int8SraOp -> sizedPrimOp OP_ASR+++    IntNeOp -> sizedPrimOp OP_NEQ+    Int64NeOp -> only64bit $ sizedPrimOp OP_NEQ+    Int32NeOp -> sizedPrimOp OP_NEQ+    Int16NeOp -> sizedPrimOp OP_NEQ+    Int8NeOp -> sizedPrimOp OP_NEQ+    WordNeOp -> sizedPrimOp OP_NEQ+    Word64NeOp -> only64bit $ sizedPrimOp OP_NEQ+    Word32NeOp -> sizedPrimOp OP_NEQ+    Word16NeOp -> sizedPrimOp OP_NEQ+    Word8NeOp -> sizedPrimOp OP_NEQ+    AddrNeOp -> sizedPrimOp OP_NEQ++    IntEqOp -> sizedPrimOp OP_EQ+    Int64EqOp -> only64bit $ sizedPrimOp OP_EQ+    Int32EqOp -> sizedPrimOp OP_EQ+    Int16EqOp -> sizedPrimOp OP_EQ+    Int8EqOp -> sizedPrimOp OP_EQ+    WordEqOp -> sizedPrimOp OP_EQ+    Word64EqOp -> only64bit $ sizedPrimOp OP_EQ+    Word32EqOp -> sizedPrimOp OP_EQ+    Word16EqOp -> sizedPrimOp OP_EQ+    Word8EqOp -> sizedPrimOp OP_EQ+    AddrEqOp -> sizedPrimOp OP_EQ+    CharEqOp -> sizedPrimOp OP_EQ++    IntLtOp -> sizedPrimOp OP_S_LT+    Int64LtOp -> only64bit $ sizedPrimOp OP_S_LT+    Int32LtOp -> sizedPrimOp OP_S_LT+    Int16LtOp -> sizedPrimOp OP_S_LT+    Int8LtOp -> sizedPrimOp OP_S_LT+    WordLtOp -> sizedPrimOp OP_U_LT+    Word64LtOp -> only64bit $ sizedPrimOp OP_U_LT+    Word32LtOp -> sizedPrimOp OP_U_LT+    Word16LtOp -> sizedPrimOp OP_U_LT+    Word8LtOp -> sizedPrimOp OP_U_LT+    AddrLtOp -> sizedPrimOp OP_U_LT+    CharLtOp -> sizedPrimOp OP_U_LT++    IntGeOp -> sizedPrimOp OP_S_GE+    Int64GeOp -> only64bit $ sizedPrimOp OP_S_GE+    Int32GeOp -> sizedPrimOp OP_S_GE+    Int16GeOp -> sizedPrimOp OP_S_GE+    Int8GeOp -> sizedPrimOp OP_S_GE+    WordGeOp -> sizedPrimOp OP_U_GE+    Word64GeOp -> only64bit $ sizedPrimOp OP_U_GE+    Word32GeOp -> sizedPrimOp OP_U_GE+    Word16GeOp -> sizedPrimOp OP_U_GE+    Word8GeOp -> sizedPrimOp OP_U_GE+    AddrGeOp -> sizedPrimOp OP_U_GE+    CharGeOp -> sizedPrimOp OP_U_GE++    IntGtOp -> sizedPrimOp OP_S_GT+    Int64GtOp -> only64bit $ sizedPrimOp OP_S_GT+    Int32GtOp -> sizedPrimOp OP_S_GT+    Int16GtOp -> sizedPrimOp OP_S_GT+    Int8GtOp -> sizedPrimOp OP_S_GT+    WordGtOp -> sizedPrimOp OP_U_GT+    Word64GtOp -> only64bit $ sizedPrimOp OP_U_GT+    Word32GtOp -> sizedPrimOp OP_U_GT+    Word16GtOp -> sizedPrimOp OP_U_GT+    Word8GtOp -> sizedPrimOp OP_U_GT+    AddrGtOp -> sizedPrimOp OP_U_GT+    CharGtOp -> sizedPrimOp OP_U_GT++    IntLeOp -> sizedPrimOp OP_S_LE+    Int64LeOp -> only64bit $ sizedPrimOp OP_S_LE+    Int32LeOp -> sizedPrimOp OP_S_LE+    Int16LeOp -> sizedPrimOp OP_S_LE+    Int8LeOp -> sizedPrimOp OP_S_LE+    WordLeOp -> sizedPrimOp OP_U_LE+    Word64LeOp -> only64bit $ sizedPrimOp OP_U_LE+    Word32LeOp -> sizedPrimOp OP_U_LE+    Word16LeOp -> sizedPrimOp OP_U_LE+    Word8LeOp -> sizedPrimOp OP_U_LE+    AddrLeOp -> sizedPrimOp OP_U_LE+    CharLeOp -> sizedPrimOp OP_U_LE++    IntNegOp -> sizedPrimOp OP_NEG+    Int64NegOp -> only64bit $ sizedPrimOp OP_NEG+    Int32NegOp -> sizedPrimOp OP_NEG+    Int16NegOp -> sizedPrimOp OP_NEG+    Int8NegOp -> sizedPrimOp OP_NEG++    IntToWordOp     -> mk_conv (platformWordWidth platform)+    WordToIntOp     -> mk_conv (platformWordWidth platform)+    Int8ToWord8Op   -> mk_conv W8+    Word8ToInt8Op   -> mk_conv W8+    Int16ToWord16Op -> mk_conv W16+    Word16ToInt16Op -> mk_conv W16+    Int32ToWord32Op -> mk_conv W32+    Word32ToInt32Op -> mk_conv W32+    Int64ToWord64Op -> only64bit $ mk_conv W64+    Word64ToInt64Op -> only64bit $ mk_conv W64+    IntToAddrOp     -> mk_conv (platformWordWidth platform)+    AddrToIntOp     -> mk_conv (platformWordWidth platform)+    ChrOp           -> mk_conv (platformWordWidth platform)   -- Int# and Char# are rep'd the same+    OrdOp           -> mk_conv (platformWordWidth platform)++    -- Memory primops, expand the ghci-mem-primops test if you add more.+    IndexOffAddrOp_Word8 ->  primOpWithRep (OP_INDEX_ADDR W8) W8+    IndexOffAddrOp_Word16 -> primOpWithRep (OP_INDEX_ADDR W16) W16+    IndexOffAddrOp_Word32 -> primOpWithRep (OP_INDEX_ADDR W32) W32+    IndexOffAddrOp_Word64 -> only64bit $ primOpWithRep (OP_INDEX_ADDR W64) W64++    _ -> Nothing+  where+    only64bit = if platformWordWidth platform == W64 then id else const Nothing+    primArg1Width :: StgArg -> Width+    primArg1Width arg+      | rep <- (stgArgRepU arg)+      = case rep of+        AddrRep -> platformWordWidth platform+        IntRep -> platformWordWidth platform+        WordRep -> platformWordWidth platform++        Int64Rep -> W64+        Word64Rep -> W64++        Int32Rep -> W32+        Word32Rep -> W32++        Int16Rep -> W16+        Word16Rep -> W16++        Int8Rep -> W8+        Word8Rep -> W8++        FloatRep -> unexpectedRep+        DoubleRep -> unexpectedRep++        BoxedRep{} -> unexpectedRep+        VecRep{} -> unexpectedRep+      where+        unexpectedRep = panic "doPrimOp: Unexpected argument rep"+++    -- TODO: The slides for the result need to be two words on 32bit for 64bit ops.+    mkNReturn width+      | W64 <- width = RETURN L -- L works for 64 bit on any platform+      | otherwise = RETURN N -- <64bit width, fits in word on all platforms++    mkSlideWords width = if platformWordWidth platform < width then 2 else 1++    -- Push args, execute primop, slide, return_N+    -- Decides width of operation based on first argument.+    sizedPrimOp op_inst = Just $ do+      let width = primArg1Width (head args)+      prim_code <- mkPrimOpCode init_d s p (op_inst width) $ args+      let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width+      return $ prim_code `appOL` slide++    -- primOpWithRep op w => operation @op@ resulting in result @w@ wide.+    primOpWithRep :: BCInstr -> Width -> Maybe (BcM (OrdList BCInstr))+    primOpWithRep op_inst result_width = Just $ do+      prim_code <- mkPrimOpCode init_d s p op_inst $ args+      let slide = mkSlideW (mkSlideWords result_width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn result_width+      return $ prim_code `appOL` slide++    -- Coerce the argument, requires them to be the same size+    mk_conv :: Width -> Maybe (BcM (OrdList BCInstr))+    mk_conv target_width = Just $ do+      let width = primArg1Width (head args)+      massert (width == target_width)+      (push_code, _bytes) <- pushAtom init_d p (head args)+      let slide = mkSlideW (mkSlideWords target_width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn target_width+      return $ push_code `appOL` slide++-- Push the arguments on the stack and emit the given instruction+-- Pushes at least one word per non void arg.+mkPrimOpCode+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> BCInstr                  -- The operator+    -> [StgArg]                 -- Args, in *reverse* order (must be fully applied)+    -> BcM BCInstrList+mkPrimOpCode orig_d _ p op_inst args = app_code+  where+    app_code = do+        profile <- getProfile+        let _platform = profilePlatform profile++            do_pushery :: StackDepth -> [StgArg] -> BcM BCInstrList+            do_pushery !d (arg : args) = do+                (push,arg_bytes) <- pushAtom d p arg+                more_push_code <- do_pushery (d + arg_bytes) args+                return (push `appOL` more_push_code)+            do_pushery !_d [] = do+                return (unitOL op_inst)++        -- Push on the stack in the reverse order.+        do_pushery orig_d (reverse args)+ -- v. similar to CgStackery.findMatch, ToDo: merge findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) findPushSeq (P: P: P: P: P: P: rest)@@ -843,6 +1096,12 @@ -- ----------------------------------------------------------------------------- -- Case expressions +-- | Generate ByteCode for a case expression.+--+-- Note that case BCOs may be "nested" within other parent BCOs and refer to+-- its parent's variables (as in the 'BCEnv' contains variables from parent+-- frames). For more details about the interaction between case BCOs and their+-- parent frames see Note [Case continuation BCOs]. doCase     :: StackDepth     -> Sequel@@ -881,43 +1140,41 @@         -- When an alt is entered, it assumes the returned value is         -- on top of the itbl; see Note [Return convention for non-tuple values]         -- for details.-        ret_frame_size_b :: StackDepth-        ret_frame_size_b | ubx_tuple_frame =-                             (if profiling then 5 else 4) * wordSize platform-                         | otherwise = 2 * wordSize platform+        ctoi_frame_header_w :: WordOff+        ctoi_frame_header_w+          | ubx_tuple_frame =+              if profiling then 5 else 4+          | otherwise = 2 +        -- The size of the ret_*_info frame header, whose frame returns the+        -- value to the case continuation frame (ctoi_*_info)+        ret_info_header_w :: WordOff+          | ubx_tuple_frame = 3+          | otherwise = 1+         -- The stack space used to save/restore the CCCS when profiling         save_ccs_size_b | profiling &&                           not ubx_tuple_frame = 2 * wordSize platform                         | otherwise = 0 -        -- The size of the return frame info table pointer if one exists-        unlifted_itbl_size_b :: StackDepth-        unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform-                             | otherwise       = 0-         (bndr_size, call_info, args_offsets)            | ubx_tuple_frame =                let bndr_reps = typePrimRep (idType bndr)                    (call_info, args_offsets) =                        layoutNativeCall profile NativeTupleReturn 0 id bndr_reps-               in ( wordsToBytes platform (nativeCallSize call_info)+               in ( nativeCallSize call_info                   , call_info                   , args_offsets                   )-           | otherwise = ( wordsToBytes platform (idSizeW platform bndr)+           | otherwise = ( idSizeW platform bndr                          , voidTupleReturnInfo                          , []                          ) -        -- depth of stack after the return value has been pushed+        -- Depth of stack after the return value has been pushed+        -- This is the stack depth at the continuation.         d_bndr =-            d + ret_frame_size_b + bndr_size--        -- depth of stack after the extra info table for an unlifted return-        -- has been pushed, if any.  This is the stack depth at the-        -- continuation.-        d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b+            d + wordsToBytes platform bndr_size          -- Env in which to compile the alts, not including         -- any vars bound by the alts themselves@@ -929,13 +1186,13 @@         -- given an alt, return a discr and code for it.         codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)         codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs}-           = do rhs_code <- schemeE d_alts s p_alts rhs+           = do rhs_code <- schemeE d_bndr s p_alts rhs                 return (NoDiscr, rhs_code)          codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}            -- primitive or nullary constructor alt: no need to UNPACK            | null real_bndrs = do-                rhs_code <- schemeE d_alts s p_alts rhs+                rhs_code <- schemeE d_bndr s p_alts rhs                 return (my_discr alt, rhs_code)            | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =              let bndr_ty = idPrimRepU . fromNonVoid@@ -947,7 +1204,7 @@                                     bndr_ty                                     (assertNonVoidIds bndrs) -                 stack_bot = d_alts+                 stack_bot = d_bndr                   p' = Map.insertList                         [ (arg, tuple_start -@@ -965,7 +1222,7 @@                          (addIdReps (assertNonVoidIds real_bndrs))                  size = WordOff tot_wds -                 stack_bot = d_alts + wordsToBytes platform size+                 stack_bot = d_bndr + wordsToBytes platform size                   -- convert offsets from Sp into offsets into the virtual stack                  p' = Map.insertList@@ -1065,29 +1322,170 @@      alt_stuff <- mapM codeAlt alts      alt_final0 <- mkMultiBranch maybe_ncons alt_stuff -     let alt_final-           | ubx_tuple_frame    = SLIDE 0 2 `consOL` alt_final0-           | otherwise          = alt_final0+     let +         -- drop the stg_ctoi_*_info header...+         alt_final1 = SLIDE bndr_size ctoi_frame_header_w `consOL` alt_final0++         -- after dropping the stg_ret_*_info header+         alt_final2 = SLIDE 0 ret_info_header_w `consOL` alt_final1++     -- When entering a case continuation BCO, the stack is always headed+     -- by the stg_ret frame and the stg_ctoi frame that returned to it.+     -- See Note [Stack layout when entering run_BCO]+     --+     -- Right after the breakpoint instruction, a case continuation BCO+     -- drops the stg_ret and stg_ctoi frame headers (see alt_final1,+     -- alt_final2), leaving the stack with the scrutinee followed by the+     -- free variables (with depth==d_bndr)+     alt_final <- getLastBreakTick >>= \case+       Just (Breakpoint tick_ty tick_id fvs)+         | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)+         -- Construct an internal breakpoint to put at the start of this case+         -- continuation BCO, for step-out.+         -- See Note [Debugger: Stepout internal break locs]+         -> do++          -- same fvs available in the surrounding tick are available in the case continuation++          -- The variable offsets into the yielded AP_STACK are adjusted+          -- differently because a case continuation AP_STACK has the+          -- additional stg_ret and stg_ctoi frame headers+          -- (as per Note [Stack layout when entering run_BCO]):+          let firstVarOff = ret_info_header_w+bndr_size+ctoi_frame_header_w+              idOffSets = map (fmap (second (+firstVarOff))) $+                          getVarOffSets platform d p fvs+              ty_vars   = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)+              toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)+              toWord = fmap (\(i, wo) -> (i, fromIntegral wo))+              breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty+                            (Left (InternalBreakLoc tick_id))++          mibi <- newBreakInfo breakInfo+          return $ case mibi of+            Nothing  -> alt_final2+            Just ibi -> BRK_FUN ibi `consOL` alt_final2+       _ -> pure alt_final2++     add_bco_name <- shouldAddBcoName      let          alt_bco_name = getName bndr-         alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)+         alt_bco = mkProtoBCO platform add_bco_name alt_bco_name alt_final (Left alts)                        0{-no arity-} bitmap_size bitmap True{-is alts-}-     scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)-                           (d + ret_frame_size_b + save_ccs_size_b)+     scrut_code <- schemeE (d + wordsToBytes platform ctoi_frame_header_w + save_ccs_size_b)+                           (d + wordsToBytes platform ctoi_frame_header_w + save_ccs_size_b)                            p scrut-     alt_bco' <- emitBc alt_bco      if ubx_tuple_frame-       then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)-               return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco+       then do let tuple_bco = tupleBCO platform call_info args_offsets+               return (PUSH_ALTS_TUPLE alt_bco call_info tuple_bco                        `consOL` scrut_code)        else let scrut_rep = case non_void_arg_reps of                   []    -> V                   [rep] -> rep                   _     -> panic "schemeE(StgCase).push_alts"-            in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code)+            in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code) +{-+Note [Debugger: Stepout internal break locs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Step-out tells the interpreter to run until the current function+returns to where it was called from, and stop there. +This is achieved by enabling the BRK_FUN found on the first RET_BCO+frame on the stack (See [Note Debugger: Step-out]).++Case continuation BCOs (which select an alternative branch) must+therefore be headed by a BRK_FUN. An example:++    f x = case g x of <--- end up here+        1 -> ...+        2 -> ...++    g y = ... <--- step out from here++- `g` will return a value to the case continuation BCO in `f`+- The case continuation BCO will receive the value returned from g+- Match on it and push the alternative continuation for that branch+- And then enter that alternative.++If we step-out of `g`, the first RET_BCO on the stack is the case+continuation of `f` -- execution should stop at its start, before+selecting an alternative. (One might ask, "why not enable the breakpoint+in the alternative instead?", because the alternative continuation is+only pushed to the stack *after* it is selected by the case cont. BCO)++However, the case cont. BCO is not associated with any source-level+tick, it is merely the glue code which selects alternatives which do+have source level ticks. Therefore, we have to come up at code+generation time with a breakpoint location ('InternalBreakLoc') to+display to the user when it is stopped there.++Our solution is to use the last tick seen just before reaching the case+continuation. This is robust because a case continuation will thus+always have a relevant breakpoint location:++    - The source location will be the last source-relevant expression+      executed before the continuation is pushed++    - So the source location will point to the thing you've just stepped+      out of++    - The variables available are the same as the ones bound just before entering++    - Doing :step-local from there will put you on the selected+      alternative (which at the source level may also be the e.g. next+      line in a do-block)++Examples, using angle brackets (<<...>>) to denote the breakpoint span:++    f x = case <<g x>> {- step in here -} of+        1 -> ...+        2 -> ...>++    g y = <<...>> <--- step out from here++    ...++    f x = <<case g x of <--- end up here, whole case highlighted+        1 -> ...+        2 -> ...>>++    doing :step-local ...++    f x = case g x of+        1 -> <<...>> <--- stop in the alternative+        2 -> ...++A second example based on T26042d2, where the source is a do-block IO+action, optimised to a chain of `case expressions`.++    main = do+      putStrLn "hello1"+      <<f>> <--- step-in here+      putStrLn "hello3"+      putStrLn "hello4"++    f = do+      <<putStrLn "hello2.1">> <--- step-out from here+      putStrLn "hello2.2"++    ...++    main = do+      putStrLn "hello1"+      <<f>> <--- end up here again, the previously executed expression+      putStrLn "hello3"+      putStrLn "hello4"++    doing step/step-local ...++    main = do+      putStrLn "hello1"+      f+      <<putStrLn "hello3">> <--- straight to the next line+      putStrLn "hello4"+-}+ -- ----------------------------------------------------------------------------- -- Deal with tuples @@ -1377,10 +1775,10 @@   -} -tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name+tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name tupleBCO platform args_info args =-  mkProtoBCO platform invented_name body_code (Left [])-             0{-no arity-} bitmap_size bitmap False{-is alts-}+  mkProtoBCO platform Nothing invented_name body_code (Left [])+             0{-no arity-} bitmap_size bitmap False{-not alts-}   where     {-       The tuple BCO is never referred to by name, so we can get away@@ -1398,10 +1796,10 @@     body_code = mkSlideW 0 1          -- pop frame header                 `snocOL` RETURN_TUPLE -- and add it again -primCallBCO ::  Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name+primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name primCallBCO platform args_info args =-  mkProtoBCO platform invented_name body_code (Left [])-             0{-no arity-} bitmap_size bitmap False{-is alts-}+  mkProtoBCO platform Nothing invented_name body_code (Left [])+             0{-no arity-} bitmap_size bitmap False{-not alts-}   where     {-       The primcall BCO is never referred to by name, so we can get away@@ -1507,7 +1905,7 @@                                           massert (off == dd + szb)                                           go (dd + szb) (push:pushes) cs      push_args <- go d [] shifted_args_offsets-     args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets)+     let args_bco = primCallBCO platform args_info prim_args_offsets      return $ mconcat push_args `appOL`               (push_target `consOL`                push_info `consOL`@@ -1685,13 +2083,10 @@       let ffires = primRepToFFIType platform r_rep          ffiargs = map (primRepToFFIType platform) a_reps-     interp <- hscInterp <$> getHscEnv-     token <- ioToBc $ interpCmd interp (PrepFFI ffiargs ffires)-     recordFFIBc token       let          -- do the call-         do_call      = unitOL (CCALL stk_offset token flags)+         do_call      = unitOL (CCALL stk_offset (FFIInfo ffiargs ffires) flags)            where flags = case safety of                            PlaySafe          -> 0x0                            PlayInterruptible -> 0x1@@ -1793,7 +2188,7 @@     extract_constr_Names ty            | rep_ty <- unwrapType ty            , Just tyc <- tyConAppTyCon_maybe rep_ty-           , isDataTyCon tyc+           , isBoxedDataTyCon tyc            = map (getName . dataConWorkId) (tyConDataCons tyc)            -- NOTE: use the worker name, not the source name of            -- the DataCon.  See "GHC.Core.DataCon" for details.@@ -1842,7 +2237,7 @@ implement_tagToId d s p arg names   = assert (notNull names) $     do (push_arg, arg_bytes) <- pushAtom d p arg-       labels <- getLabelsBc (genericLength names)+       labels <- getLabelsBc (strictGenericLength names)        label_fail <- getLabelBc        label_exit <- getLabelBc        dflags <- getDynFlags@@ -1879,9 +2274,7 @@ -- to 5 and not to 4.  Stack locations are numbered from zero, so a -- depth 6 stack has valid words 0 .. 5. -pushAtom-    :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)-+pushAtom :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff) -- See Note [Empty case alternatives] in GHC.Core -- and Note [Bottoming expressions] in GHC.Core.Utils: -- The scrutinee of an empty case evaluates to bottom@@ -1937,14 +2330,17 @@            _             -- see Note [Generating code for top-level string literal bindings]-            | isUnliftedType (idType var) -> do-              massert (idType var `eqType` addrPrimTy)+            | idType var `eqType` addrPrimTy ->               return (unitOL (PUSH_ADDR (getName var)), szb)              | otherwise -> do+              let varTy = idType var+              massertPpr (definitelyLiftedType varTy) $+                vcat [ text "pushAtom: unhandled unlifted type"+                     , text "var:" <+> ppr var <+> dcolon <+> ppr varTy <> dcolon <+> ppr (typeKind varTy)+                     ]               return (unitOL (PUSH_G (getName var)), szb) - pushAtom _ _ (StgLitArg lit) = pushLiteral True lit  pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)@@ -1953,7 +2349,13 @@      platform <- targetPlatform <$> getDynFlags      let code :: PrimRep -> BcM (BCInstrList, ByteOff)          code rep =-            return (padding_instr `snocOL` instr, size_bytes + padding_bytes)+            -- TODO: It's a bit silly to use up to four instructions to put a single literal on the stack.+            --       Lot's of better ways to do this. Add a instruction to push it as full word.+            --       Store the literal as full word and push it as full word.+            --       Maybe more, but for now this will do.+            case platformByteOrder platform of+              LittleEndian -> return (padding_instr `snocOL` instr, size_bytes + padding_bytes)+              BigEndian -> return (instr `consOL` padding_instr, size_bytes + padding_bytes)           where             size_bytes = ByteOff $ primRepSizeB platform rep @@ -2279,103 +2681,96 @@ -- ----------------------------------------------------------------------------- -- The bytecode generator's monad +-- | Read only environment for generating ByteCode+data BcM_Env+   = BcM_Env+        { bcm_hsc_env    :: !HscEnv+        , bcm_module     :: !Module -- current module (for breakpoints)+        , modBreaks      :: !(Maybe ModBreaks)+        , last_bp_tick   :: !(Maybe StgTickish)+        }+ data BcM_State    = BcM_State-        { bcm_hsc_env :: HscEnv-        , thisModule  :: Module          -- current module (for breakpoints)-        , nextlabel   :: Word32          -- for generating local labels-        , ffis        :: [FFIInfo]       -- ffi info blocks, to free later-                                         -- Should be free()d when it is GCd-        , modBreaks   :: Maybe ModBreaks -- info about breakpoints--        , breakInfo   :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence.-                                            -- Indexed with breakpoint *info* index.-                                            -- See Note [Breakpoint identifiers]-                                            -- in GHC.Types.Breakpoint-        , breakInfoIdx :: !Int              -- ^ Next index for breakInfo array+        { nextlabel      :: !Word32 -- ^ For generating local labels+        , breakInfoIdx   :: !Int    -- ^ Next index for breakInfo array+        , breakInfo      :: !(IntMap CgBreakInfo)+          -- ^ Info at breakpoints occurrences. Indexed with+          -- 'InternalBreakpointId'. See Note [Breakpoint identifiers] in+          -- GHC.ByteCode.Breakpoints.         } -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)--ioToBc :: IO a -> BcM a-ioToBc io = BcM $ \st -> do-  x <- io-  return (st, x)--runBc :: HscEnv -> Module -> Maybe ModBreaks-      -> BcM r-      -> IO (BcM_State, r)-runBc hsc_env this_mod modBreaks (BcM m)-   = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty 0)--thenBc :: BcM a -> (a -> BcM b) -> BcM b-thenBc (BcM expr) cont = BcM $ \st0 -> do-  (st1, q) <- expr st0-  let BcM k = cont q-  (st2, r) <- k st1-  return (st2, r)--thenBc_ :: BcM a -> BcM b -> BcM b-thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do-  (st1, _) <- expr st0-  (st2, r) <- cont st1-  return (st2, r)--returnBc :: a -> BcM a-returnBc result = BcM $ \st -> (return (st, result))--instance Applicative BcM where-    pure = returnBc-    (<*>) = ap-    (*>) = thenBc_+newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State))+  deriving (Functor, Applicative, Monad, MonadIO)+    via (ReaderT BcM_Env (StateT BcM_State IO)) -instance Monad BcM where-  (>>=) = thenBc-  (>>)  = (*>)+runBc :: HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (r, BcM_State)+runBc hsc_env this_mod mbs (BcM m)+   = m (BcM_Env hsc_env this_mod mbs Nothing) (BcM_State 0 0 IntMap.empty)  instance HasDynFlags BcM where-    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))+    getDynFlags = hsc_dflags <$> getHscEnv  getHscEnv :: BcM HscEnv-getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)+getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st)  getProfile :: BcM Profile getProfile = targetProfile <$> getDynFlags -emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)-emitBc bco-  = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))--recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()-recordFFIBc a-  = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())+shouldAddBcoName :: BcM (Maybe Module)+shouldAddBcoName = do+  add <- gopt Opt_AddBcoName <$> getDynFlags+  if add+    then Just <$> getCurrentModule+    else return Nothing  getLabelBc :: BcM LocalLabel-getLabelBc-  = BcM $ \st -> do let nl = nextlabel st-                    when (nl == maxBound) $-                        panic "getLabelBc: Ran out of labels"-                    return (st{nextlabel = nl + 1}, LocalLabel nl)+getLabelBc = BcM $ \_ st ->+  do let nl = nextlabel st+     when (nl == maxBound) $+         panic "getLabelBc: Ran out of labels"+     return (LocalLabel nl, st{nextlabel = nl + 1})  getLabelsBc :: Word32 -> BcM [LocalLabel]-getLabelsBc n-  = BcM $ \st -> let ctr = nextlabel st-                 in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])+getLabelsBc n = BcM $ \_ st ->+  let ctr = nextlabel st+   in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) -newBreakInfo :: CgBreakInfo -> BcM Int-newBreakInfo info = BcM $ \st ->-  let ix = breakInfoIdx st-      st' = st-              { breakInfo = IntMap.insert ix info (breakInfo st)-              , breakInfoIdx = ix + 1-              }-  in return (st', ix)+newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId)+newBreakInfo info = BcM $ \env st -> do+  -- if we're not generating ModBreaks for this module for some reason, we+  -- can't store breakpoint occurrence information.+  case modBreaks env of+    Nothing -> pure (Nothing, st)+    Just modBreaks -> do+      let ix = breakInfoIdx st+          st' = st+            { breakInfo = IntMap.insert ix info (breakInfo st)+            , breakInfoIdx = ix + 1+            }+      return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st')  getCurrentModule :: BcM Module-getCurrentModule = BcM $ \st -> return (st, thisModule st)+getCurrentModule = BcM $ \env st -> return (bcm_module env, st) -getCurrentModBreaks :: BcM (Maybe ModBreaks)-getCurrentModBreaks = BcM $ \st -> return (st, modBreaks st)+withBreakTick :: StgTickish -> BcM a -> BcM a+withBreakTick bp (BcM act) = BcM $ \env st ->+  act env{last_bp_tick=Just bp} st +getLastBreakTick :: BcM (Maybe StgTickish)+getLastBreakTick = BcM $ \env st ->+  pure (last_bp_tick env, st)+ tickFS :: FastString tickFS = fsLit "ticked"++-- Dehydrating CgBreakInfo++dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo+dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid =+          CgBreakInfo+            { cgb_tyvars = map toIfaceTvBndr ty_vars+            , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets+            , cgb_resty = toIfaceType tick_ty+            , cgb_tick_id = bid+            }
compiler/GHC/StgToCmm.hs view
@@ -78,7 +78,7 @@                                        -- Output as a stream, so codegen can                                        -- be interleaved with output -codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) data_tycons+codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) tycons         cost_centre_info stg_binds   = do  {     -- cg: run the code generator, and yield the resulting CmmGroup               -- Using an IORef to store the state is a bit crude, but otherwise@@ -117,19 +117,12 @@         ; cg (mkModuleInit cost_centre_info)          ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds-                -- Put datatype_stuff after code_stuff, because the+                -- Put datatype_stuff (cgTyCon) after code_stuff (cgTopBinding), because the                 -- datatype closure table (for enumeration types) to                 -- (say) PrelBase_True_closure, which is defined in                 -- code_stuff-        ; let do_tycon tycon = do-                -- Generate a table of static closures for an-                -- enumeration type Note that the closure pointers are-                -- tagged.-                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)-                 -- Emit normal info_tables, for data constructors defined in this module.-                 mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon) -        ; mapM_ do_tycon data_tycons+        ; mapM_ (cg . cgTyCon) tycons          -- Emit special info tables for everything used in this module         -- This will only do something if  `-fdistinct-info-tables` is turned on.@@ -285,18 +278,37 @@   ------------------------------------------------------------------      Generating static stuff for algebraic data types+--   Generating static stuff for algebraic data types, including+--     * entry code for each data con+--     * info table for each data con+--     * for enumerations, a table of all the closures --------------------------------------------------------------- +---------------------------------------------------------------+--      Data type constructors+---------------------------------------------------------------+cgTyCon :: TyCon -> FCode ()+-- Generate static data for each algebraic data type+cgTyCon tycon+  | not (isBoxedDataTyCon tycon)  -- Type families, newtypes, and `type data` constructors+  = return () +  | otherwise   -- An honest-to-goodness algebraic data type+  = do { -- Emit normal info_tables, for data constructors defined in this module.+         mapM_ (cgDataCon DefinitionSite) (tyConDataCons tycon)++       ; when (isEnumerationTyCon tycon) $+         cgEnumerationTyCon tycon }+ cgEnumerationTyCon :: TyCon -> FCode ()+-- Generate a table of static closures for an enumeration type.+-- Note that the closure pointers in the table are tagged. cgEnumerationTyCon tycon   = do platform <- getPlatform        emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs)              [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs)                            (tagForCon platform con)              | con <- tyConDataCons tycon]-  cgDataCon :: ConInfoTableLocation -> DataCon -> FCode () -- Generate the entry code, info tables, and (for niladic constructor)
compiler/GHC/StgToCmm/Bind.hs view
@@ -391,7 +391,7 @@                          -- thunk (e.g. its type) (#949)   , idArity fun_id == unknownArity -- don't spoil a known call           -- Ha! an Ap thunk-  , not check_tags -- See Note [Tag inference debugging]+  , not check_tags -- See Note [EPT enforcement debugging]   = cgRhsStdThunk bndr lf_info payload    where
compiler/GHC/StgToCmm/Closure.hs view
@@ -98,7 +98,7 @@ import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 import GHC.StgToCmm.Config-import GHC.Stg.InferTags.TagSig (isTaggedSig)+import GHC.Stg.EnforceEpt.TagSig (isTaggedSig)  ----------------------------------------------------------------------------- --                Data types and synonyms@@ -508,8 +508,8 @@                         -- or constructor), so just return it.    | InferedReturnIt     -- A properly tagged value, as determined by tag inference.-                        -- See Note [Tag Inference] and Note [Tag inference passes] in-                        -- GHC.Stg.InferTags.+                        -- See Note [Evaluated and Properly Tagged]+                        -- and Note [EPT enforcement] in GHC.Stg.EnforceEpt.                         -- It behaves /precisely/ like `ReturnIt`, except that when debugging is                         -- enabled we emit an extra assertion to check that the returned value is                         -- properly tagged.  We can use this as a check that tag inference is working@@ -583,8 +583,8 @@               n_args _cg_loc _self_loop_info    | Just sig <- idTagSig_maybe id-  , isTaggedSig sig -- Infered to be already evaluated by Tag Inference-  , n_args == 0     -- See Note [Tag Inference]+  , isTaggedSig sig -- Infered to be already evaluated by EPT analysis+  , n_args == 0     -- See Note [EPT enforcement]   = InferedReturnIt    | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)@@ -621,12 +621,12 @@ getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _cg_locs _self_loop_info   | n_args == 0   , Just sig <- idTagSig_maybe id-  , isTaggedSig sig -- Infered to be already evaluated by Tag Inference+  , isTaggedSig sig -- Infered to be already evaluated by EPT analysis   -- When profiling we must enter all potential functions to make sure we update the SCC   -- even if the function itself is already evaluated.   -- See Note [Evaluating functions with profiling] in rts/Apply.cmm   , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function)-  = InferedReturnIt -- See Note [Tag Inference]+  = InferedReturnIt -- See Note [EPT enforcement]    | might_be_a_function = SlowCall 
compiler/GHC/StgToCmm/Expr.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} @@ -56,7 +55,7 @@ import Control.Monad ( unless, void ) import Control.Arrow ( first ) import Data.List     ( partition )-import GHC.Stg.InferTags.TagSig (isTaggedSig)+import GHC.Stg.EnforceEpt.TagSig (isTaggedSig) import GHC.Platform.Profile (profileIsProfiling)  ------------------------------------------------------------------------@@ -178,7 +177,7 @@  cgLetNoEscapeRhs join_id local_cc bndr rhs =   do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs-     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info+     ; let (bid, _) = expectJust $ maybeLetNoEscape info      ; let code = do { (_, body) <- getCodeScoped rhs_code                      ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }      ; return (info, code)@@ -729,7 +728,9 @@         ; tagged_cmms <- cgAltRhss gc_plan bndr alts          ; let bndr_reg = CmmLocal (idToReg platform bndr)-              (DEFAULT,deflt) = head tagged_cmms+              deflt = case tagged_cmms of+                  (DEFAULT,deflt):_ -> deflt+                  _ -> panic "cgAlts PrimAlt"                 -- PrimAlts always have a DEFAULT case                 -- and it always comes first 
compiler/GHC/StgToCmm/Foreign.hs view
@@ -720,7 +720,7 @@ -- Precondition: args and typs have the same length -- See Note [Unlifted boxed arguments to foreign calls] getFCallArgs args typ-  = do  { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ))+  = do  { mb_cmms <- mapM get (zipEqual args (collectStgFArgTypes typ))         ; return (catMaybes mb_cmms) }   where     get (arg,typ)
compiler/GHC/StgToCmm/Layout.hs view
@@ -64,6 +64,7 @@ import Control.Monad import GHC.StgToCmm.Config (stgToCmmPlatform) import GHC.StgToCmm.Types+import Data.List.NonEmpty (nonEmpty)  ------------------------------------------------------------------------ --                Call and return sequences@@ -376,24 +377,25 @@ -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. slowArgs :: Platform -> [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)]-slowArgs _ []  _        = mempty slowArgs platform args sccProfilingEnabled  -- careful: reps contains voids (V), but args does not-  | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs platform rest_args sccProfilingEnabled-  | otherwise           =              this_pat ++ slowArgs platform rest_args sccProfilingEnabled-  where-    (arg_pat, n)            = slowCallPattern (map fst args)-    (call_args, rest_args)  = splitAt n args+  = case nonEmpty args of+    Nothing -> mempty+    Just args1+      | sccProfilingEnabled -> save_cccs ++ this_pat ++ slowArgs platform rest_args sccProfilingEnabled+      | otherwise           ->              this_pat ++ slowArgs platform rest_args sccProfilingEnabled+      where+        (arg_pat, n)            = slowCallPattern (fmap fst args)+        (call_args, rest_args)  = splitAt n args -    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat-    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args-    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just $ cccsExpr platform)]-    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit $ "stg_restore_cccs_" ++ arg_reps)-    arg_reps =-      case maximum (map fst args) of-        V64 -> "v64"-        V32 -> "v32"-        V16 -> "v16"-        _   -> "d"+        stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat+        this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args+        save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just $ cccsExpr platform)]+        save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit $ "stg_restore_cccs_" ++ arg_reps)+        arg_reps = case maximum (fmap fst args1) of+            V64 -> "v64"+            V32 -> "v32"+            V16 -> "v16"+            _   -> "d"   
compiler/GHC/StgToCmm/Lit.hs view
@@ -51,7 +51,7 @@   CmmLit <$> newByteStringCLit s  -- not unpackFS; we want the UTF-8 byte stream. cgLit (LitRubbish _ rep) =-  case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants]+  case expectOnly prim_reps of -- Note [Post-unarisation invariants]     BoxedRep _  -> idInfoToAmode <$> getCgIdInfo unitDataConId     AddrRep     -> cgLit LitNullAddr     VecRep n elem -> do
compiler/GHC/StgToCmm/Prim.hs view
@@ -46,6 +46,7 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe  import Control.Monad (liftM, when, unless, zipWithM_)@@ -1533,20 +1534,28 @@   (VecSubOp  IntVec n w) -> opTranslate (MO_V_Sub   n w)   (VecMulOp  IntVec n w) -> opTranslate (MO_V_Mul   n w)   (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"-  (VecQuotOp IntVec n w) -> opTranslate (MO_VS_Quot n w)-  (VecRemOp  IntVec n w) -> opTranslate (MO_VS_Rem  n w)+  (VecQuotOp IntVec n w) -> opCallish (MO_VS_Quot n w)+  (VecRemOp  IntVec n w) -> opCallish (MO_VS_Rem n w)   (VecNegOp  IntVec n w) -> opTranslate (MO_VS_Neg  n w)+  (VecMinOp  IntVec 2 W64)+    | not allowIntWord64X2MinMax -> opCallish MO_I64X2_Min   (VecMinOp  IntVec n w) -> opTranslate (MO_VS_Min  n w)+  (VecMaxOp  IntVec 2 W64)+    | not allowIntWord64X2MinMax -> opCallish MO_I64X2_Max   (VecMaxOp  IntVec n w) -> opTranslate (MO_VS_Max  n w)    (VecAddOp  WordVec n w) -> opTranslate (MO_V_Add   n w)   (VecSubOp  WordVec n w) -> opTranslate (MO_V_Sub   n w)   (VecMulOp  WordVec n w) -> opTranslate (MO_V_Mul   n w)   (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"-  (VecQuotOp WordVec n w) -> opTranslate (MO_VU_Quot n w)-  (VecRemOp  WordVec n w) -> opTranslate (MO_VU_Rem  n w)+  (VecQuotOp WordVec n w) -> opCallish (MO_VU_Quot n w)+  (VecRemOp  WordVec n w) -> opCallish (MO_VU_Rem n w)   (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"+  (VecMinOp  WordVec 2 W64)+    | not allowIntWord64X2MinMax -> opCallish MO_W64X2_Min   (VecMinOp  WordVec n w) -> opTranslate (MO_VU_Min  n w)+  (VecMaxOp  WordVec 2 W64)+    | not allowIntWord64X2MinMax -> opCallish MO_W64X2_Max   (VecMaxOp  WordVec n w) -> opTranslate (MO_VU_Max  n w)    -- Vector FMA instructions@@ -1571,28 +1580,28 @@   CastDoubleToWord64Op -> translateBitcasts (MO_FW_Bitcast W64)   CastWord64ToDoubleOp -> translateBitcasts (MO_WF_Bitcast W64) -  IntQuotRemOp -> opCallishHandledLater $-    if allowQuotRem+  IntQuotRemOp -> \args -> flip opCallishHandledLater args $+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem  (wordWidth platform))     else Right (genericIntQuotRemOp (wordWidth platform)) -  Int8QuotRemOp -> opCallishHandledLater $-    if allowQuotRem+  Int8QuotRemOp -> \args -> flip opCallishHandledLater args $+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem W8)     else Right (genericIntQuotRemOp W8) -  Int16QuotRemOp -> opCallishHandledLater $-    if allowQuotRem+  Int16QuotRemOp -> \args -> flip opCallishHandledLater args $+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem W16)     else Right (genericIntQuotRemOp W16) -  Int32QuotRemOp -> opCallishHandledLater $-    if allowQuotRem+  Int32QuotRemOp -> \args -> flip opCallishHandledLater args $+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem W32)     else Right (genericIntQuotRemOp W32) -  WordQuotRemOp -> opCallishHandledLater $-    if allowQuotRem+  WordQuotRemOp -> \args -> flip opCallishHandledLater args $+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem  (wordWidth platform))     else Right (genericWordQuotRemOp (wordWidth platform)) @@ -1601,18 +1610,18 @@     then Left (MO_U_QuotRem2 (wordWidth platform))     else Right (genericWordQuotRem2Op platform) -  Word8QuotRemOp -> opCallishHandledLater $-    if allowQuotRem+  Word8QuotRemOp -> \args -> flip opCallishHandledLater args $+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem W8)     else Right (genericWordQuotRemOp W8) -  Word16QuotRemOp -> opCallishHandledLater $-    if allowQuotRem+  Word16QuotRemOp -> \args -> flip opCallishHandledLater args $+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem W16)     else Right (genericWordQuotRemOp W16) -  Word32QuotRemOp -> opCallishHandledLater $-    if allowQuotRem+  Word32QuotRemOp -> \args -> flip opCallishHandledLater args $+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem W32)     else Right (genericWordQuotRemOp W32) @@ -1716,9 +1725,6 @@   ReadMVarOp -> alwaysExternal   TryReadMVarOp -> alwaysExternal   IsEmptyMVarOp -> alwaysExternal-  NewIOPortOp -> alwaysExternal-  ReadIOPortOp -> alwaysExternal-  WriteIOPortOp -> alwaysExternal   DelayOp -> alwaysExternal   WaitReadOp -> alwaysExternal   WaitWriteOp -> alwaysExternal@@ -1762,10 +1768,12 @@   WhereFromOp   -> alwaysExternal   GetApStackValOp -> alwaysExternal   ClearCCSOp -> alwaysExternal+  AnnotateStackOp -> alwaysExternal   TraceEventOp -> alwaysExternal   TraceEventBinaryOp -> alwaysExternal   TraceMarkerOp -> alwaysExternal   SetThreadAllocationCounter -> alwaysExternal+  SetOtherThreadAllocationCounter -> alwaysExternal   KeepAliveOp -> alwaysExternal   where@@ -1835,6 +1843,23 @@     pure $ map (CmmReg . CmmLocal) regs    alwaysExternal = \_ -> PrimopCmmEmit_External+  -- Note [QuotRem optimization]+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+  -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops+  -- (shift, .&.).+  --+  -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the+  -- constant is a power of 2. #9041 tracks the implementation of the general+  -- optimization.+  --+  -- `quotRem` can be optimized in the same way. However as it returns two values,+  -- it is implemented as a "callish" primop which is harder to match and+  -- to transform later on. For simplicity, the current implementation detects cases+  -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem+  -- primop into two CMM quot and rem primops.+  quotRemCanBeOptimized = \case+    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)+    _                         -> False    allowQuotRem  = stgToCmmAllowQuotRemInstr         cfg   allowQuotRem2 = stgToCmmAllowQuotRem2             cfg@@ -1843,6 +1868,7 @@   allowWord2Mul = stgToCmmAllowWordMul2Instr        cfg   allowArith64  = stgToCmmAllowArith64              cfg   allowQuot64   = stgToCmmAllowQuot64               cfg+  allowIntWord64X2MinMax = stgToCmmAllowIntWord64X2MinMax cfg    -- a bit of a hack, for certain code generaters, e.g. PPC, and i386 we   -- continue to use the cmm versions of these functions instead of inline@@ -2254,17 +2280,21 @@               mkAssign xhyl                   (mul (topHalf arg_x) (bottomHalf arg_y)),               mkAssign r-                  (sum [topHalf    (CmmReg xlyl),-                        bottomHalf (CmmReg xhyl),-                        bottomHalf (CmmReg xlyh)]),+                  (sum $+                   topHalf    (CmmReg xlyl) :|+                   bottomHalf (CmmReg xhyl) :+                   bottomHalf (CmmReg xlyh) :+                   []),               mkAssign (CmmLocal res_l)                   (or (bottomHalf (CmmReg xlyl))                       (toTopHalf (CmmReg r))),               mkAssign (CmmLocal res_h)-                  (sum [mul (topHalf arg_x) (topHalf arg_y),-                        topHalf (CmmReg xhyl),-                        topHalf (CmmReg xlyh),-                        topHalf (CmmReg r)])]+                  (sum $+                   mul (topHalf arg_x) (topHalf arg_y) :|+                   topHalf (CmmReg xhyl) :+                   topHalf (CmmReg xlyh) :+                   topHalf (CmmReg r) :+                   [])] genericWordMul2Op _ _ = panic "genericWordMul2Op"  genericIntMul2Op :: GenericOp@@ -2707,13 +2737,15 @@ doShuffleOp :: CmmType -> [CmmExpr] -> LocalReg -> FCode () doShuffleOp ty (v1:v2:idxs) res   | isVecType ty+  -- The type checker ensures that the indices have the correct length,+  -- so we only need to check whether the indices are constants and within the valid range.   = case mapMaybe idx_maybe idxs of       is         | length is == len         -> emitAssign (CmmLocal res) (CmmMachOp (mo is) [v1,v2])         | otherwise-        -> pprPanic "doShuffleOp" $-             vcat [ text "shuffle indices must be literals, 0 <= i <" <+> ppr len ]+        -> pgmErrorDoc "Vector shuffle:" $+             vcat [ text "shuffle indices must be literals, 0 <= i <" <+> ppr (2 * len) ]   | otherwise   = pprPanic "doShuffleOp" $         vcat [ text "non-vector argument type:" <+> ppr ty ]@@ -2935,7 +2967,7 @@     let byteArrayAlignment = wordAlignment platform         srcOffAlignment = cmmExprAlignment src_off         dstOffAlignment = cmmExprAlignment dst_off-        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]+        align = minimum (byteArrayAlignment :| srcOffAlignment : dstOffAlignment : [])     dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off     src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off     copy src dst dst_p src_p n align
compiler/GHC/StgToCmm/TagCheck.hs view
@@ -175,4 +175,3 @@           then return ()           else pprPanic "Arg not tagged as expected" (ppr msg <+> ppr arg) -
compiler/GHC/StgToJS/Apply.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}  ----------------------------------------------------------------------------- -- |@@ -46,11 +47,13 @@ import GHC.StgToJS.Symbols import GHC.StgToJS.Types import GHC.StgToJS.Utils+import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8)  import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.CostCentre import GHC.Types.RepType (mightBeFunTy)+import GHC.Types.Literal  import GHC.Stg.Syntax @@ -86,7 +89,6 @@      , moveRegs2      ] - -- | Generate an application of some args to an Id. -- -- The case where args is null is common as it's used to generate the evaluation@@ -98,6 +100,84 @@   -> [StgArg]   -> G (JStgStat, ExprResult) genApp ctx i args+    -- Test case moved to T24744+    -- See: https://github.com/ghcjs/ghcjs/blob/b7711fbca7c3f43a61f1dba526e6f2a2656ef44c/src/Gen2/Generator.hs#L876+    -- Comment by Luite Stegeman <luite.stegeman@iohk.io>+    -- Special cases for JSString literals.+    -- We could handle unpackNBytes# here, but that's probably not common+    -- enough to warrant a special case.+    -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588/#note_503978+    -- Comment by Jeffrey Young  <jeffrey.young@iohk.io>+    -- We detect if the Id is unsafeUnpackJSStringUtf8## applied to a string literal,+    -- if so then we convert the unsafeUnpack to a call to h$decode.+    | [StgVarArg v] <- args+    , idName i == unsafeUnpackJSStringUtf8ShShName+    -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588+    -- Comment by Josh Meredith  <josh.meredith@iohk.io>+    -- `typex_expr` can throw an error for certain bindings so it's important+    -- that this condition comes after matching on the function name+    , [top] <- concatMap typex_expr (ctxTarget ctx)+    = (,ExprInline) . (|=) top . app hdDecodeUtf8Z <$> varsForId v++    -- Test case T23479+    | [StgLitArg (LitString bs)] <- args+    , Just d <- decodeModifiedUTF8 bs+    , idName i == unsafeUnpackJSStringUtf8ShShName+    , [top] <- concatMap typex_expr (ctxTarget ctx)+    = return . (,ExprInline) $ top |= toJExpr d++    -- Test case T24495 with single occurrence at -02 and third occurrence at -01+    -- Moved back from removal at https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12308+    -- See commit hash b36ee57bfbecc628b7f0919e1e59b7066495034f+    --+    -- Case: unpackCStringAppend# "some string"# str+    --+    -- Generates h$appendToHsStringA(str, "some string"), which has a faster+    -- decoding loop.+    | [StgLitArg (LitString bs), x] <- args+    , Just d <- decodeModifiedUTF8 bs+    , getUnique i == unpackCStringAppendIdKey+    , [top] <- concatMap typex_expr (ctxTarget ctx)+    = do+        prof <- csProf <$> getSettings+        let profArg = if prof then [jCafCCS] else []+        a <- genArg x+        return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)+               , ExprInline+               )+    | [StgLitArg (LitString bs), x] <- args+    , Just d <- decodeModifiedUTF8 bs+    , getUnique i == unpackCStringAppendUtf8IdKey+    , [top] <- concatMap typex_expr (ctxTarget ctx)+    = do+        prof <- csProf <$> getSettings+        let profArg = if prof then [jCafCCS] else []+        a <- genArg x+        return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg)+               , ExprInline+               )++    -- Case: unpackCString# "some string"#+    --+    -- Generates h$toHsString("some string"), which has a faster+    -- decoding loop.+    -- + Utf8 version below+    | [StgLitArg (LitString bs)] <- args+    , Just d <- decodeModifiedUTF8 bs+    , idName i == unpackCStringName+    , [top] <- concatMap typex_expr (ctxTarget ctx)+    = return+        ( top |= app "h$toHsStringA" [toJExpr d]+        , ExprInline+        )+    | [StgLitArg (LitString bs)] <- args+    , Just d <- decodeModifiedUTF8 bs+    , idName i == unpackCStringUtf8Name+    , [top] <- concatMap typex_expr (ctxTarget ctx)+    = return+        ( top |= app "h$toHsString" [toJExpr d]+        , ExprInline+        )      -- let-no-escape     | Just n <- ctxLneBindingStackSize ctx i
compiler/GHC/StgToJS/Arg.hs view
@@ -22,9 +22,6 @@   , genIdArgI   , genIdStackArgI   , allocConStatic-  , allocUnboxedConStatic-  , allocateStaticList-  , jsStaticArg   , jsStaticArgs   ) where@@ -215,7 +212,7 @@            emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc'       | otherwise = do            e <- identFS <$> identForDataConWorker con-           emitStatic to (StaticData e []) cc'+           emitStatic to (StaticApp SAKData e []) cc'     allocConStatic' cc' [x]       | isUnboxableCon con =         case x of@@ -234,7 +231,7 @@                 _         -> panic "allocConStatic: invalid args for consDataCon"               else do                 e <- identFS <$> identForDataConWorker con-                emitStatic to (StaticData e xs) cc'+                emitStatic to (StaticApp SAKData e xs) cc'  -- | Allocate unboxed constructors allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
compiler/GHC/StgToJS/CodeGen.hs view
@@ -11,7 +11,7 @@  import GHC.Prelude -import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js))+import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js, Opt_D_dump_stg_from_js_sinker))  import GHC.JS.Ppr import GHC.JS.JStg.Syntax@@ -21,7 +21,7 @@ import GHC.JS.Optimizer  import GHC.StgToJS.Arg-import GHC.StgToJS.Sinker+import GHC.StgToJS.Sinker.Sinker import GHC.StgToJS.Types import qualified GHC.StgToJS.Object as Object import GHC.StgToJS.Utils@@ -48,6 +48,7 @@ import GHC.Types.RepType import GHC.Types.Id import GHC.Types.Unique+import GHC.Types.Unique.FM (nonDetEltsUFM)  import GHC.Data.FastString import GHC.Utils.Encoding@@ -60,6 +61,7 @@  import qualified Data.Set as S import Data.Monoid+import Data.List (sortBy) import Control.Monad import System.Directory import System.FilePath@@ -81,7 +83,8 @@     -- TODO: avoid top level lifting in core-2-core when the JS backend is     -- enabled instead of undoing it here -    -- TODO: add dump pass for optimized STG ast for JS+  putDumpFileMaybe logger Opt_D_dump_stg_from_js_sinker "STG Optimized JS Sinker:" FormatSTG+    (pprGenStgTopBindings (StgPprOpts False) stg_binds)    (deps,lus) <- runG config this_mod unfloated_binds $ do     ifProfilingM $ initCostCentres cccs@@ -326,25 +329,27 @@     eid  <- identForEntryId i     idt  <- identFS <$> identForId i     body <- genBody (initExprCtx i) R2 args body typ-    global_occs <- globalOccs body+    occs <- globalOccs body+    let lids = global_id <$> (sortBy cmp_cnt $ nonDetEltsUFM occs)+    -- Regenerate idents from lids to restore right order of representatives.+    -- Representatives have occurrence order which can be mixed.+    lidents <- concat <$> traverse identsForId lids     let eidt = identFS eid-    let lidents = map global_ident global_occs-    let lids    = map global_id    global_occs     let lidents' = map identFS lidents     CIStaticRefs sr0 <- genStaticRefsRhs rhs     let sri = filter (`notElem` lidents') sr0         sr   = CIStaticRefs sri     et <- genEntryType args     ll <- loadLiveFun lids-    (static, regs, upd) <-+    (appK, regs, upd) <-       if et == CIThunk         then do           r <- updateThunk-          pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r)-        else return (StaticFun eidt (map StaticObjArg lidents'),-                    (if null lidents then CIRegs 1 (concatMap idJSRep args)-                                     else CIRegs 0 (PtrV : concatMap idJSRep args))-                      , mempty)+          pure (SAKThunk, CIRegs 0 [PtrV], r)+        else+          let regs = if null lidents then CIRegs 1 (concatMap idJSRep args)+                                     else CIRegs 0 (PtrV : concatMap idJSRep args)+          in pure (SAKFun, regs, mempty)     setcc <- ifProfiling $                if et == CIThunk                  then enterCostCentreThunk@@ -358,5 +363,8 @@       , ciStatic = sr       }     ccId <- costCentreStackLbl cc-    emitStatic idt static ccId+    emitStatic idt (StaticApp appK eidt $ map StaticObjArg lidents') ccId     return $ (FuncStat eid [] (ll <> upd <> setcc <> body))+    where+      cmp_cnt :: GlobalOcc -> GlobalOcc -> Ordering+      cmp_cnt g1 g2 = compare (global_count g1) (global_count g2)
compiler/GHC/StgToJS/Expr.hs view
@@ -54,6 +54,7 @@ import GHC.StgToJS.Symbols import GHC.StgToJS.Types import GHC.StgToJS.Utils+import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8)  import GHC.Types.CostCentre import GHC.Types.Tickish@@ -76,7 +77,6 @@ import GHC.Core.Type hiding (typeSize)  import GHC.Utils.Misc-import GHC.Utils.Encoding import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)@@ -86,6 +86,7 @@  import qualified GHC.Data.List.SetOps as ListSetOps +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Monoid import Data.Maybe import Data.Function@@ -581,7 +582,7 @@   , getUnique i == unpackCStringAppendIdKey   , [StgVarArg b',x] <- args   , bnd == b'-  , d <- utf8DecodeByteString bs+  , Just d <- decodeModifiedUTF8 bs   , [top] <- concatMap typex_expr (ctxTarget ctx)   = do       prof <- csProf <$> getSettings@@ -590,7 +591,54 @@       return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)              , ExprInline              )+  | StgLit (LitString bs) <- e+  , [GenStgAlt DEFAULT _ rhs] <- alts+  , StgApp i args <- rhs+  , getUnique i == unpackCStringAppendUtf8IdKey+  , [StgVarArg b',x] <- args+  , bnd == b'+  , Just d <- decodeModifiedUTF8 bs+  , [top] <- concatMap typex_expr (ctxTarget ctx)+  = do+      prof <- csProf <$> getSettings+      let profArg = if prof then [jCafCCS] else []+      a <- genArg x+      return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg)+             , ExprInline+             ) +  -- The latter has a faster decoding loop.+  --+  --    case "some string"# of b {+  --      DEFAULT -> unpackCString# b+  --    }+  --+  -- + Utf8 version below+  | StgLit (LitString bs) <- e+  , [GenStgAlt DEFAULT _ rhs] <- alts+  , StgApp i args <- rhs+  , idName i == unpackCStringName+  , [StgVarArg b'] <- args+  , bnd == b'+  , Just d <- decodeModifiedUTF8 bs+  , [top] <- concatMap typex_expr (ctxTarget ctx)+  = return+      ( top |= app "h$toHsStringA" [toJExpr d]+      , ExprInline+      )+  | StgLit (LitString bs) <- e+  , [GenStgAlt DEFAULT _ rhs] <- alts+  , StgApp i args <- rhs+  , idName i == unpackCStringUtf8Name+  , [StgVarArg b'] <- args+  , bnd == b'+  , Just d <- decodeModifiedUTF8 bs+  , [top] <- concatMap typex_expr (ctxTarget ctx)+  = return+      ( top |= app "h$toHsString" [toJExpr d]+      , ExprInline+      )+   | isInlineExpr e = do       bndi <- identsForId bnd       let ctx' = ctxSetTop bnd@@ -634,7 +682,7 @@     allRefs :: [Id]     allRefs =  S.toList . S.unions $ fmap (exprRefs emptyUFM . alt_rhs) as     lneLive :: Int-    lneLive    = maximum $ 0 : catMaybes (map (ctxLneBindingStackSize ctx) allRefs)+    lneLive    = maximum $ 0 :| catMaybes (map (ctxLneBindingStackSize ctx) allRefs)     ctx'       = ctxLneShrinkStack ctx lneLive     lneVars    = map fst $ ctxLneFrameVars ctx'     isLne i    = ctxIsLneBinding ctx i || ctxIsLneLiveVar ctx' i@@ -870,7 +918,7 @@ -- mkEq :: [JStgExpr] -> [JStgExpr] -> JStgExpr mkEq es1 es2-  | length es1 == length es2 = foldl1 (InfixExpr LAndOp) (zipWith (InfixExpr StrictEqOp) es1 es2)+  | length es1 == length es2 = L.foldl1 (InfixExpr LAndOp) (zipWith (InfixExpr StrictEqOp) es1 es2)   | otherwise                = panic "mkEq: incompatible expressions"  mkAlgBranch :: ExprCtx   -- ^ toplevel id for the result
compiler/GHC/StgToJS/ExprCtx.hs view
@@ -46,7 +46,7 @@ import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Stg.InferTags.TagSig+import GHC.Stg.EnforceEpt.TagSig  import GHC.Utils.Outputable import GHC.Utils.Panic@@ -85,6 +85,16 @@     -- ^ Cache the length of `ctxLneFrameVars`    }++instance Outputable ExprCtx where+  ppr g = hang (text "ExprCtx") 2 $ vcat+            [ hcat [text "ctxTop: ", ppr (ctxTop g)]+            , hcat [text "ctxTarget:", ppr (ctxTarget g)]+            , hcat [text "ctxSrcSpan:", ppr (ctxSrcSpan g)]+            , hcat [text "ctxLneFrameBs:", ppr (ctxLneFrameBs g)]+            , hcat [text "ctxLneFrameVars:", ppr (ctxLneFrameVars g)]+            , hcat [text "ctxLneFrameSize:", ppr (ctxLneFrameSize g)]+            ]  -- | Initialize an expression context in the context of the given top-level -- binding Id
compiler/GHC/StgToJS/Ids.hs view
@@ -155,7 +155,7 @@    -- Now update the GlobalId cache, if required -  let update_global_cache = isGlobalId i && isNothing mi && id_type == IdPlain+  let update_global_cache = isGlobalId i && id_type == IdPlain       -- fixme also allow caching entries for lifting?    when (update_global_cache) $ do
compiler/GHC/StgToJS/Linker/Linker.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TupleSections     #-} {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE BlockArguments    #-}+{-# LANGUAGE MultiWayIf        #-}  ----------------------------------------------------------------------------- -- |@@ -24,8 +25,6 @@   ( jsLinkBinary   , jsLink   , embedJsFile-  , staticInitStat-  , staticDeclStat   , mkExportedFuns   , mkExportedModFuns   , computeLinkDependencies@@ -101,7 +100,7 @@ import Data.Function            (on) import qualified Data.IntSet              as IS import Data.IORef-import Data.List  ( nub, intercalate, groupBy, intersperse, sortBy)+import Data.List  ( nub, intercalate, groupBy, intersperse ) import Data.Map.Strict          (Map) import qualified Data.Map.Strict          as M import Data.Maybe@@ -123,6 +122,7 @@ import GHC.Unit.Finder.Types import GHC.Unit.Finder (findObjectLinkableMaybe, findHomeModule) import GHC.Driver.Config.Finder (initFinderOpts)+import qualified GHC.Unit.Home.Graph as HUG  data LinkerStats = LinkerStats   { bytesPerModule     :: !(Map Module Word64) -- ^ number of bytes linked per module@@ -462,6 +462,9 @@    -- all the units we want to link together, without their dependencies   let root_units = filter (/= ue_currentUnit unit_env)+                   -- fendor: GHCi uses more 'UnidIds' than just 'interactiveUnitId'.+                   -- If this breaks for some reason,+                   -- see Note [Multiple Home Units aware GHCi] for GHCi session setup.                    $ filter (/= interactiveUnitId)                    $ nub                    $ rts_wired_units ++ reverse obj_units ++ reverse units@@ -483,7 +486,7 @@   new_required_blocks_var <- newIORef []   let load_info mod = do         -- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps.-        linkable <- case lookupHugByModule mod (ue_home_unit_graph unit_env) of+        linkable <- HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case           Nothing ->                 -- It's not in the HPT because we are in one shot mode,                 -- so use the Finder to get a ModLocation...@@ -548,6 +551,16 @@   , mc_frefs    :: ![ForeignJSRef]   } +instance Outputable ModuleCode where+  ppr m = hang (text "ModuleCode") 2 $ vcat+            [ hcat [text "Module: ", ppr (mc_module m)]+            , hcat [text "JS Code:", pretty True (mc_js_code m)]+            , hcat [text "JS Exports:", pprHsBytes (mc_exports m)]+            , hang (text "JS Closures::") 2 (vcat (fmap (text . show) (mc_closures m)))+            , hang (text "JS Statics::") 2 (vcat (fmap (text . show) (mc_statics m)))+            , hang (text "JS ForeignRefs::") 2 (vcat (fmap (text . show) (mc_frefs m)))+            ]+ -- | ModuleCode after link with other modules. -- -- It contains less information than ModuleCode because they have been commoned@@ -654,14 +667,21 @@   getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath]-getPackageArchives cfg unit_env units =-  filterM doesFileExist [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a"-                        | u <- units-                        , p <- getInstalledPackageLibDirs ue_state u-                        , l <- getInstalledPackageHsLibs  ue_state u-                        ]+getPackageArchives cfg unit_env units = do+  fmap concat $ forM units $ \u -> do+    let archives = [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a"+                   | p <- getInstalledPackageLibDirs ue_state u+                   , l <- getInstalledPackageHsLibs  ue_state u+                   ]+    foundArchives <- filterM doesFileExist archives+    if | not (null archives)+       , null foundArchives+       -> do+         throwGhcExceptionIO (InstallationError $ "Could not find any library archives for unit-id: " <> (renderWithContext (csContext cfg) $ ppr u))+       | otherwise+       -> pure foundArchives   where-    ue_state = ue_units unit_env+    ue_state = ue_homeUnitState unit_env      -- XXX the profiling library name is probably wrong now     profSuff | csProf cfg = "_p"@@ -917,22 +937,8 @@       module_blocks = M.fromListWith IS.union $                       map (\ref -> (block_ref_mod ref, IS.singleton (block_ref_idx ref))) (S.toList blocks) -  -- GHCJS had this comment: "read ghc-prim first, since we depend on that for-  -- static initialization". Not sure if it's still true as we haven't ported-  -- the compactor yet. Still we sort to read ghc-prim blocks first just in-  -- case.-  let pred x = moduleUnitId (fst x) == primUnitId-      cmp x y = case (pred x, pred y) of-        (True,False)  -> LT-        (False,True)  -> GT-        (True,True)   -> EQ-        (False,False) -> EQ--      sorted_module_blocks :: [(Module,BlockIds)]-      sorted_module_blocks = sortBy cmp (M.toList module_blocks)-   -- load blocks-  forM sorted_module_blocks $ \(mod,bids) -> do+  forM (M.toList module_blocks) $ \(mod,bids) -> do     case M.lookup mod block_info of       Nothing  -> pprPanic "collectModuleCodes: couldn't find block info for module" (ppr mod)       Just lbi -> extractBlocks ar_cache lbi bids@@ -1004,7 +1010,7 @@ -- | dependencies for the RTS, these need to be always linked rtsDeps :: ([UnitId], Set ExportedFun) rtsDeps =-  ( [ghcInternalUnitId, primUnitId]+  ( [ghcInternalUnitId]   , S.fromList $ concat       [ mkInternalFuns "GHC.Internal.Conc.Sync"           ["reportError"]@@ -1045,11 +1051,11 @@           , "setCurrentThreadResultException"           , "setCurrentThreadResultValue"           ]-      , mkPrimFuns "GHC.Types"+      , mkInternalFuns "GHC.Internal.Types"           [ ":"           , "[]"           ]-      , mkPrimFuns "GHC.Tuple"+      , mkInternalFuns "GHC.Internal.Tuple"           [ "(,)"           , "(,,)"           , "(,,,)"@@ -1067,10 +1073,6 @@ mkInternalFuns :: FastString -> [FastString] -> [ExportedFun] mkInternalFuns = mkExportedFuns ghcInternalUnitId --- | Export the Prim functions-mkPrimFuns :: FastString -> [FastString] -> [ExportedFun]-mkPrimFuns = mkExportedFuns primUnitId- -- | Given a @UnitId@, a module name, and a set of symbols in the module, -- package these into an @ExportedFun@. mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun]@@ -1243,27 +1245,22 @@ staticInitStat (StaticInfo i sv mcc) =   jStgStatToJS $   case sv of-    StaticData con args         -> appS hdStiStr $ add_cc_arg-                                    [ global i-                                    , global con-                                    , jsStaticArgs args-                                    ]-    StaticFun  f   args         -> appS hdStiStr $ add_cc_arg-                                    [ global i-                                    , global f-                                    , jsStaticArgs args-                                    ]-    StaticList args mt          -> appS hdStlStr $ add_cc_arg-                                    [ global i-                                    , jsStaticArgs args-                                    , toJExpr $ maybe null_ (toJExpr . TxtI) mt-                                    ]-    StaticThunk (Just (f,args)) -> appS hdStcStr $ add_cc_arg-                                    [ global i-                                    , global f-                                    , jsStaticArgs args-                                    ]-    _                           -> mempty+    (StaticApp k app args) -> appS+                              (if k == SAKThunk then hdStcStr else hdStiStr)+                              $ add_cc_arg+                                [ global i+                                , global app+                                , jsStaticArgs args+                                ]++    StaticList args mt     -> appS hdStlStr+                              $ add_cc_arg+                              [ global i+                              , jsStaticArgs args+                              , toJExpr $ maybe null_ (toJExpr . TxtI) mt+                              ]++    StaticUnboxed _             -> mempty   where     -- add optional cost-center argument     add_cc_arg as = case mcc of@@ -1276,20 +1273,15 @@   where     global_ident = name global_name     decl_init v  = global_ident ||= v-    decl_no_init = appS hdDiStr [toJExpr global_ident]      decl = case static_value of       StaticUnboxed u     -> decl_init (unboxed_expr u)-      StaticThunk Nothing -> decl_no_init -- CAF initialized in an alternative way       _                   -> decl_init (app hdDStr [])      unboxed_expr = \case       StaticUnboxedBool b          -> app hdPStr [toJExpr b]       StaticUnboxedInt i           -> app hdPStr [toJExpr i]       StaticUnboxedDouble d        -> app hdPStr [toJExpr (unSaneDouble d)]-      -- GHCJS used a function wrapper for this:-      -- StaticUnboxedString str      -> ApplExpr (initStr str) []-      -- But we are defining it statically for now.       StaticUnboxedString str      -> initStr str       StaticUnboxedStringOffset {} -> 0 
compiler/GHC/StgToJS/Linker/Utils.hs view
@@ -77,13 +77,15 @@ -- | Generate macros MK_TUP* for tuples sized 2+. genMkTup :: Bool -> Int -> ByteString genMkTup profiling n = mconcat-  [ "#define MK_TUP", sn                                                          -- #define MK_TUPn-  , "(", B.intercalate "," xs, ")"                                                -- (x1,x2,...)-  , "(h$c", sn, "("                                                               -- (h$cn(-  , bytesFS symbol, ","                                                           -- h$ghczmprimZCGHCziTupleziZnT_con_e,                                                                        -- ,-  , B.intercalate "," $ map (\x -> "(" <> x <> ")") xs                            -- (x1),(x2),(...)-  , if profiling then ",h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM" else "" -- ,h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM-  , "))\n"                                                                        -- ))\n+  [ "#define MK_TUP", sn                                        -- #define MK_TUPn+  , "(", B.intercalate "," xs, ")"                              -- (x1,x2,...)+  , "(h$c", sn, "("                                             -- (h$cn(+  , bytesFS symbol, ","                                         -- h$ghczminternalZCGHCziInternalziTupleziZnT_con_e,+  , B.intercalate "," $ map (\x -> "(" <> x <> ")") xs          -- (x1),(x2),(...)+  , if profiling                                                -- ,h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM+      then ",h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM"+      else ""+  , "))\n"                                                      -- ))\n   ]   where     xs = take n $ map (("x" <>) . Char8.pack . show) ([1..] :: [Int])@@ -154,20 +156,20 @@       else "#define MK_JUST(val) (h$c1(h$ghczminternalZCGHCziInternalziMaybeziJust_con_e, (val)))\n"    -- Data.List-  , "#define HS_NIL h$ghczmprimZCGHCziTypesziZMZN\n"-  , "#define HS_NIL_CON h$ghczmprimZCGHCziTypesziZMZN_con_e\n"-  , "#define IS_CONS(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZC_con_e)\n"-  , "#define IS_NIL(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZMZN_con_e)\n"+  , "#define HS_NIL h$ghczminternalZCGHCziInternalziTypesziZMZN\n"+  , "#define HS_NIL_CON h$ghczminternalZCGHCziInternalziTypesziZMZN_con_e\n"+  , "#define IS_CONS(cl) ((cl).f === h$ghczminternalZCGHCziInternalziTypesziZC_con_e)\n"+  , "#define IS_NIL(cl) ((cl).f === h$ghczminternalZCGHCziInternalziTypesziZMZN_con_e)\n"   , "#define CONS_HEAD(cl) ((cl).d1)\n"   , "#define CONS_TAIL(cl) ((cl).d2)\n"   , if profiling       then mconcat-        [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), h$CCS_SYSTEM))\n"-        , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), (cc)))\n"+        [ "#define MK_CONS(head,tail) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail), h$CCS_SYSTEM))\n"+        , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail), (cc)))\n"         ]       else mconcat-        [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n"-        , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n"+        [ "#define MK_CONS(head,tail) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail)))\n"+        , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail)))\n"         ]    -- Data.Text
compiler/GHC/StgToJS/Literal.hs view
@@ -18,8 +18,8 @@ import GHC.StgToJS.Monad import GHC.StgToJS.Symbols import GHC.StgToJS.Types+import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8) -import GHC.Data.FastString import GHC.Types.Literal import GHC.Types.Basic import GHC.Types.RepType@@ -95,9 +95,10 @@ genStaticLit :: Literal -> G [StaticLit] genStaticLit = \case   LitChar c                -> return [ IntLit (fromIntegral $ ord c) ]-  LitString str-    | True                 -> return [ StringLit (mkFastStringByteString str), IntLit 0]-    -- \|  invalid UTF8         -> return [ BinLit str, IntLit 0]+  LitString str -> case decodeModifiedUTF8 str of+    Just t                 -> return [ StringLit t, IntLit 0]+    -- invalid UTF8+    Nothing                -> return [ BinLit str, IntLit 0]   LitNullAddr              -> return [ NullLit, IntLit 0 ]   LitNumber nt v           -> case nt of     LitNumInt     -> return [ IntLit v ]@@ -117,7 +118,7 @@                                      , IntLit 0 ]   LitRubbish _ rep ->     let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep-    in case expectOnly "GHC.StgToJS.Literal.genStaticLit" prim_reps of -- Note [Post-unarisation invariants]+    in case expectOnly prim_reps of -- Note [Post-unarisation invariants]         BoxedRep _  -> pure [ NullLit ]         AddrRep     -> pure [ NullLit, IntLit 0 ]         IntRep      -> pure [ IntLit 0 ]
compiler/GHC/StgToJS/Monad.hs view
@@ -31,6 +31,7 @@ import GHC.StgToJS.Types  import GHC.Unit.Module+import GHC.Utils.Outputable import GHC.Stg.Syntax  import GHC.Types.SrcLoc@@ -44,7 +45,6 @@  import qualified Data.Map  as M import qualified Data.Set  as S-import qualified Data.List as L  runG :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a runG config m unfloat action = State.evalStateT action =<< initState config m unfloat@@ -152,25 +152,30 @@ setGlobalIdCache :: GlobalIdCache -> G () setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}}) - data GlobalOcc = GlobalOcc-  { global_ident :: !Ident-  , global_id    :: !Id+  { global_id    :: !Id   , global_count :: !Word   } --- | Return number of occurrences of every global id used in the given JStgStat.+instance Outputable GlobalOcc where+  ppr g = hang (text "GlobalOcc") 2 $ vcat+            [ hcat [text "Id:", ppr (global_id g)]+            , hcat [text "Count:", ppr (global_count g)]+            ]++-- | Return occurrences of every global id used in the given JStgStat. -- Sort by increasing occurrence count.-globalOccs :: JStgStat -> G [GlobalOcc]+globalOccs :: JStgStat -> G (UniqFM Id GlobalOcc) globalOccs jst = do   GlobalIdCache gidc <- getGlobalIdCache-  -- build a map form Ident Unique to (Ident, Id, Count)+  -- build a map form Ident Unique to (Id, Count)+  -- Note that different Idents can map to the same Id (e.g. string payload and string offset idents)   let-    cmp_cnt g1 g2 = compare (global_count g1) (global_count g2)     inc g1 g2 = g1 { global_count = global_count g1 + global_count g2 }++    go :: UniqFM Id GlobalOcc -> [Ident] -> UniqFM Id GlobalOcc     go gids = \case-        []     -> -- return global Ids used locally sorted by increased use-                  L.sortBy cmp_cnt $ nonDetEltsUFM gids+        []     -> gids         (i:is) ->           -- check if the Id is global           case lookupUFM gidc i of@@ -178,7 +183,7 @@             Just (_k,gid) ->               -- add it to the list of already found global ids. Increasing               -- count by 1-              let g = GlobalOcc i gid 1-              in go (addToUFM_C inc gids i g) is+              let g = GlobalOcc gid 1+              in go (addToUFM_C inc gids gid g) is -  pure $ go emptyUFM (identsS jst)+  pure $ go emptyUFM $ identsS jst
compiler/GHC/StgToJS/Prim.hs view
@@ -1155,14 +1155,12 @@  ------------------------------ Unhandled primops ------------------- +  AnnotateStackOp                   -> unhandledPrimop op+   NewPromptTagOp                    -> unhandledPrimop op   PromptOp                          -> unhandledPrimop op   Control0Op                        -> unhandledPrimop op -  NewIOPortOp                       -> unhandledPrimop op-  ReadIOPortOp                      -> unhandledPrimop op-  WriteIOPortOp                     -> unhandledPrimop op-   GetSparkOp                        -> unhandledPrimop op   AnyToAddrOp                       -> unhandledPrimop op   MkApUpd0_Op                       -> unhandledPrimop op@@ -1173,6 +1171,7 @@   WhereFromOp                       -> unhandledPrimop op -- should be easily implementable with o.f.n    SetThreadAllocationCounter        -> unhandledPrimop op+  SetOtherThreadAllocationCounter   -> unhandledPrimop op  ------------------------------- Vector ----------------------------------------- -- For now, vectors are unsupported on the JS backend. Simply put, they do not
− compiler/GHC/StgToJS/Sinker.hs 
@@ -1,180 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}--module GHC.StgToJS.Sinker (sinkPgm) where--import GHC.Prelude-import GHC.Types.Unique.Set-import GHC.Types.Unique.FM-import GHC.Types.Var.Set-import GHC.Stg.Syntax-import GHC.Types.Id-import GHC.Types.Name-import GHC.Unit.Module-import GHC.Types.Literal-import GHC.Data.Graph.Directed--import GHC.Utils.Misc (partitionWith)-import GHC.StgToJS.Utils--import Data.Char-import Data.List (partition)-import Data.Maybe----- | Unfloat some top-level unexported things------ GHC floats constants to the top level. This is fine in native code, but with JS--- they occupy some global variable name. We can unfloat some unexported things:------ - global constructors, as long as they're referenced only once by another global---      constructor and are not in a recursive binding group--- - literals (small literals may also be sunk if they are used more than once)-sinkPgm :: Module-        -> [CgStgTopBinding]-        -> (UniqFM Id CgStgExpr, [CgStgTopBinding])-sinkPgm m pgm = (sunk, map StgTopLifted pgm'' ++ stringLits)-  where-    selectLifted (StgTopLifted b) = Left b-    selectLifted x                = Right x-    (pgm', stringLits) = partitionWith selectLifted pgm-    (sunk, pgm'')      = sinkPgm' m pgm'--sinkPgm'-  :: Module-       -- ^ the module, since we treat definitions from the current module-       -- differently-  -> [CgStgBinding]-       -- ^ the bindings-  -> (UniqFM Id CgStgExpr, [CgStgBinding])-       -- ^ a map with sunken replacements for nodes, for where the replacement-       -- does not fit in the 'StgBinding' AST and the new bindings-sinkPgm' m pgm =-  let usedOnce = collectUsedOnce pgm-      sinkables = listToUFM $-          concatMap alwaysSinkable pgm ++-          filter ((`elementOfUniqSet` usedOnce) . fst) (concatMap (onceSinkable m) pgm)-      isSunkBind (StgNonRec b _e) | elemUFM b sinkables = True-      isSunkBind _                                      = False-  in (sinkables, filter (not . isSunkBind) $ topSortDecls m pgm)---- | always sinkable, values that may be duplicated in the generated code (e.g.--- small literals)-alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)]-alwaysSinkable (StgRec {})       = []-alwaysSinkable (StgNonRec b rhs) = case rhs of-  StgRhsClosure _ _ _ _ e@(StgLit l) _-    | isSmallSinkableLit l-    , isLocal b-    -> [(b,e)]-  StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] _typ-    | isSmallSinkableLit l-    , isLocal b-    , isUnboxableCon dc-    -> [(b,StgConApp dc cnum as [])]-  _ -> []--isSmallSinkableLit :: Literal -> Bool-isSmallSinkableLit (LitChar c)     = ord c < 100000-isSmallSinkableLit (LitNumber _ i) = abs i < 100000-isSmallSinkableLit _               = False----- | once sinkable: may be sunk, but duplication is not ok-onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)]-onceSinkable _m (StgNonRec b rhs)-  | Just e <- getSinkable rhs-  , isLocal b = [(b,e)]-  where-    getSinkable = \case-      StgRhsCon _ccs dc cnum _ticks args _typ -> Just (StgConApp dc cnum args [])-      StgRhsClosure _ _ _ _ e@(StgLit{}) _typ -> Just e-      _                                       -> Nothing-onceSinkable _ _ = []---- | collect all idents used only once in an argument at the top level---   and never anywhere else-collectUsedOnce :: [CgStgBinding] -> IdSet-collectUsedOnce binds = intersectUniqSets (usedOnce args) (usedOnce top_args)-  where-    top_args = concatMap collectArgsTop binds-    args     = concatMap collectArgs    binds-    usedOnce = fst . foldr g (emptyUniqSet, emptyUniqSet)-    g i t@(once, mult)-      | i `elementOfUniqSet` mult = t-      | i `elementOfUniqSet` once-        = (delOneFromUniqSet once i, addOneToUniqSet mult i)-      | otherwise = (addOneToUniqSet once i, mult)---- | fold over all id in StgArg used at the top level in an StgRhsCon-collectArgsTop :: CgStgBinding -> [Id]-collectArgsTop = \case-  StgNonRec _b r -> collectArgsTopRhs r-  StgRec bs      -> concatMap (collectArgsTopRhs . snd) bs--collectArgsTopRhs :: CgStgRhs -> [Id]-collectArgsTopRhs = \case-  StgRhsCon _ccs _dc _mu _ticks args _typ -> concatMap collectArgsA args-  StgRhsClosure {}                        -> []---- | fold over all Id in StgArg in the AST-collectArgs :: CgStgBinding -> [Id]-collectArgs = \case-  StgNonRec _b r -> collectArgsR r-  StgRec bs      -> concatMap (collectArgsR . snd) bs--collectArgsR :: CgStgRhs -> [Id]-collectArgsR = \case-  StgRhsClosure _x0 _x1 _x2 _x3 e _typ     -> collectArgsE e-  StgRhsCon _ccs _con _mu _ticks args _typ -> concatMap collectArgsA args--collectArgsAlt :: CgStgAlt -> [Id]-collectArgsAlt alt = collectArgsE (alt_rhs alt)--collectArgsE :: CgStgExpr -> [Id]-collectArgsE = \case-  StgApp x args-    -> x : concatMap collectArgsA args-  StgConApp _con _mn args _ts-    -> concatMap collectArgsA args-  StgOpApp _x args _t-    -> concatMap collectArgsA args-  StgCase e _b _a alts-    -> collectArgsE e ++ concatMap collectArgsAlt alts-  StgLet _x b e-    -> collectArgs b ++ collectArgsE e-  StgLetNoEscape _x b e-    -> collectArgs b ++ collectArgsE e-  StgTick _i e-    -> collectArgsE e-  StgLit _-    -> []--collectArgsA :: StgArg -> [Id]-collectArgsA = \case-  StgVarArg i -> [i]-  StgLitArg _ -> []--isLocal :: Id -> Bool-isLocal i = isNothing (nameModule_maybe . idName $ i) && not (isExportedId i)---- | since we have sequential initialization, topsort the non-recursive--- constructor bindings-topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding]-topSortDecls _m binds = rest ++ nr'-  where-    (nr, rest) = partition isNonRec binds-    isNonRec StgNonRec{} = True-    isNonRec _           = False-    vs   = map getV nr-    keys = mkUniqSet (map node_key vs)-    getV e@(StgNonRec b _) = DigraphNode e b []-    getV _                 = error "topSortDecls: getV, unexpected binding"-    collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args _typ)) =-      [ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ]-    collectDeps _ = []-    g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr)-    nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g]-            = error "topSortDecls: unexpected cycle"-        | otherwise = map node_payload (topologicalSortG g)
+ compiler/GHC/StgToJS/Sinker/Collect.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE LambdaCase #-}++module GHC.StgToJS.Sinker.Collect+  ( collectArgsTop+  , collectArgs+  , selectUsedOnce+  )+  where++import GHC.Prelude+import GHC.Types.Unique.Set+import GHC.Stg.Syntax+import GHC.Types.Id+import GHC.Types.Unique++-- | fold over all id in StgArg used at the top level in an StgRhsCon+collectArgsTop :: CgStgBinding -> [Id]+collectArgsTop = \case+  StgNonRec _b r -> collectArgsTopRhs r+  StgRec bs      -> concatMap (collectArgsTopRhs . snd) bs+  where+    collectArgsTopRhs :: CgStgRhs -> [Id]+    collectArgsTopRhs = \case+      StgRhsCon _ccs _dc _mu _ticks args _typ -> concatMap collectArgsA args+      StgRhsClosure {}                        -> []++-- | fold over all Id in StgArg in the AST+collectArgs :: CgStgBinding -> [Id]+collectArgs = \case+  StgNonRec _b r -> collectArgsR r+  StgRec bs      -> concatMap (collectArgsR . snd) bs+  where+    collectArgsR :: CgStgRhs -> [Id]+    collectArgsR = \case+      StgRhsClosure _x0 _x1 _x2 _x3 e _typ     -> collectArgsE e+      StgRhsCon _ccs _con _mu _ticks args _typ -> concatMap collectArgsA args++    collectArgsAlt :: CgStgAlt -> [Id]+    collectArgsAlt alt = collectArgsE (alt_rhs alt)++    collectArgsE :: CgStgExpr -> [Id]+    collectArgsE = \case+      StgApp x args+        -> x : concatMap collectArgsA args+      StgConApp _con _mn args _ts+        -> concatMap collectArgsA args+      StgOpApp _x args _t+        -> concatMap collectArgsA args+      StgCase e _b _a alts+        -> collectArgsE e ++ concatMap collectArgsAlt alts+      StgLet _x b e+        -> collectArgs b ++ collectArgsE e+      StgLetNoEscape _x b e+        -> collectArgs b ++ collectArgsE e+      StgTick _i e+        -> collectArgsE e+      StgLit _+        -> []++collectArgsA :: StgArg -> [Id]+collectArgsA = \case+  StgVarArg i -> [i]+  StgLitArg _ -> []++selectUsedOnce :: (Foldable t, Uniquable a) => t a -> UniqSet a+selectUsedOnce = fst . foldr g (emptyUniqSet, emptyUniqSet)+  where+    g i t@(once, mult)+      | i `elementOfUniqSet` mult = t+      | i `elementOfUniqSet` once+        = (delOneFromUniqSet once i, addOneToUniqSet mult i)+      | otherwise = (addOneToUniqSet once i, mult)
+ compiler/GHC/StgToJS/Sinker/Sinker.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}++module GHC.StgToJS.Sinker.Sinker (sinkPgm) where++import GHC.Prelude+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Types.Var.Set+import GHC.Stg.Syntax+import GHC.Types.Id+import GHC.Types.Name+import GHC.Unit.Module+import GHC.Types.Literal+import GHC.Data.Graph.Directed+import GHC.StgToJS.Sinker.Collect+import GHC.StgToJS.Sinker.StringsUnfloat++import GHC.Utils.Misc (partitionWith)+import GHC.StgToJS.Utils++import Data.Char+import Data.List (partition)+import Data.Maybe+import Data.ByteString (ByteString)++-- | Unfloat some top-level unexported things+--+-- GHC floats constants to the top level. This is fine in native code, but with JS+-- they occupy some global variable name. We can unfloat some unexported things:+--+-- - global constructors, as long as they're referenced only once by another global+--      constructor and are not in a recursive binding group+-- - literals (small literals may also be sunk if they are used more than once)+sinkPgm :: Module+        -> [CgStgTopBinding]+        -> (UniqFM Id CgStgExpr, [CgStgTopBinding])+sinkPgm m pgm+  = (sunk, map StgTopLifted pgm''' ++ stringLits)+  where+    selectLifted :: CgStgTopBinding -> Either CgStgBinding (Id, ByteString)+    selectLifted (StgTopLifted b)      = Left b+    selectLifted (StgTopStringLit i b) = Right (i, b)++    (pgm', allStringLits) = partitionWith selectLifted pgm+    usedOnceIds = selectUsedOnce $ concatMap collectArgs pgm'++    stringLitsUFM = listToUFM $ (\(i, b) -> (idName i, (i, b))) <$> allStringLits+    (pgm'', _actuallyUnfloatedStringLitNames) =+      unfloatStringLits+        (idName `mapUniqSet` usedOnceIds)+        (snd `mapUFM` stringLitsUFM)+        pgm'++    stringLits = uncurry StgTopStringLit <$> allStringLits++    (sunk, pgm''') = sinkPgm' m usedOnceIds pgm''++sinkPgm'+  :: Module+       -- ^ the module, since we treat definitions from the current module+       -- differently+  -> IdSet+       -- ^ the set of used once ids+  -> [CgStgBinding]+       -- ^ the bindings+  -> (UniqFM Id CgStgExpr, [CgStgBinding])+       -- ^ a map with sunken replacements for nodes, for where the replacement+       -- does not fit in the 'StgBinding' AST and the new bindings+sinkPgm' m usedOnceIds pgm =+  let usedOnce = collectTopLevelUsedOnce usedOnceIds pgm+      sinkables = listToUFM $+          concatMap alwaysSinkable pgm +++          concatMap (filter ((`elementOfUniqSet` usedOnce) . fst) . onceSinkable m) pgm+      isSunkBind (StgNonRec b _e) | elemUFM b sinkables = True+      isSunkBind _                                      = False+  in (sinkables, filter (not . isSunkBind) $ topSortDecls m pgm)++-- | always sinkable, values that may be duplicated in the generated code (e.g.+-- small literals)+alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)]+alwaysSinkable (StgRec {})       = []+alwaysSinkable (StgNonRec b rhs) = case rhs of+  StgRhsClosure _ _ _ _ e@(StgLit l) _+    | isSmallSinkableLit l+    , isLocal b+    -> [(b,e)]+  StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] _typ+    | isSmallSinkableLit l+    , isLocal b+    , isUnboxableCon dc+    -> [(b,StgConApp dc cnum as [])]+  _ -> []++isSmallSinkableLit :: Literal -> Bool+isSmallSinkableLit (LitChar c)     = ord c < 100000+isSmallSinkableLit (LitNumber _ i) = abs i < 100000+isSmallSinkableLit _               = False+++-- | once sinkable: may be sunk, but duplication is not ok+onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)]+onceSinkable _m (StgNonRec b rhs)+  | Just e <- getSinkable rhs+  , isLocal b = [(b,e)]+  where+    getSinkable = \case+      StgRhsCon _ccs dc cnum _ticks args _typ -> Just (StgConApp dc cnum args [])+      StgRhsClosure _ _ _ _ e@(StgLit{}) _typ -> Just e+      _                                       -> Nothing+onceSinkable _ _ = []++-- | collect all idents used only once in an argument at the top level+--   and never anywhere else+collectTopLevelUsedOnce :: IdSet -> [CgStgBinding] -> IdSet+collectTopLevelUsedOnce usedOnceIds binds = intersectUniqSets usedOnceIds (selectUsedOnce top_args)+  where+    top_args = concatMap collectArgsTop binds++isLocal :: Id -> Bool+isLocal i = isNothing (nameModule_maybe . idName $ i) && not (isExportedId i)++-- | since we have sequential initialization, topsort the non-recursive+-- constructor bindings+topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding]+topSortDecls _m binds = rest ++ nr'+  where+    (nr, rest) = partition isNonRec binds+    isNonRec StgNonRec{} = True+    isNonRec _           = False+    vs   = map getV nr+    keys = mkUniqSet (map node_key vs)+    getV e@(StgNonRec b _) = DigraphNode e b []+    getV _                 = error "topSortDecls: getV, unexpected binding"+    collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args _typ)) =+      [ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ]+    collectDeps _ = []+    g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr)+    nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g]+            = error "topSortDecls: unexpected cycle"+        | otherwise = map node_payload (topologicalSortG g)
+ compiler/GHC/StgToJS/Sinker/StringsUnfloat.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}++module GHC.StgToJS.Sinker.StringsUnfloat+  ( unfloatStringLits+  )+  where++import GHC.Prelude+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Stg.Syntax+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Literal+import GHC.Utils.Misc (partitionWith)++import Data.ByteString qualified as BS+import Data.ByteString (ByteString)+import Data.Bifunctor (Bifunctor (..))++-- | We suppose that every string shorter than 80 symbols is safe for sink.+-- Sinker is working on per module. It means that ALL locally defined strings+-- in a module shorter 80 symbols will be unfloated back.+pattern STRING_LIT_MAX_LENGTH :: Int+pattern STRING_LIT_MAX_LENGTH = 80++unfloatStringLits+  :: UniqSet Name+  -> UniqFM Name ByteString+  -> [CgStgBinding]+  -> ([CgStgBinding], UniqSet Name)+unfloatStringLits usedOnceStringLits stringLits =+  unfloatStringLits' (selectStringLitsForUnfloat usedOnceStringLits stringLits)++-- | We are doing attempts to unfloat string literals back to+-- the call site. Further special JS optimizations+-- can generate more performant operations over them.+unfloatStringLits' :: UniqFM Name ByteString -> [CgStgBinding] -> ([CgStgBinding], UniqSet Name)+unfloatStringLits' stringLits allBindings = (binderWithoutChanges ++ binderWithUnfloatedStringLit, actuallyUsedStringLitNames)+  where+    (binderWithoutChanges, binderWithUnfloatedStringLitPairs) = partitionWith substituteStringLit allBindings++    binderWithUnfloatedStringLit = fst <$> binderWithUnfloatedStringLitPairs+    actuallyUsedStringLitNames = unionManyUniqSets (snd <$> binderWithUnfloatedStringLitPairs)++    substituteStringLit :: CgStgBinding -> Either CgStgBinding (CgStgBinding, UniqSet Name)+    substituteStringLit x@(StgRec bnds)+      | isEmptyUniqSet names = Left x+      | otherwise = Right (StgRec bnds', names)+      where+        (bnds', names) = extractNames id $ do+          (i, rhs) <- bnds+          pure $ case processStgRhs rhs of+            Nothing -> Left (i, rhs)+            Just (rhs', names) -> Right ((i, rhs'), names)+    substituteStringLit x@(StgNonRec binder rhs)+      = maybe (Left x)+        (\(body', names) -> Right (StgNonRec binder body', names))+        (processStgRhs rhs)++    processStgRhs :: CgStgRhs -> Maybe (CgStgRhs, UniqSet Name)+    processStgRhs (StgRhsCon ccs dataCon mu ticks args typ)+      | isEmptyUniqSet names = Nothing+      | otherwise = Just (StgRhsCon ccs dataCon mu ticks unified typ, names)+      where+        (unified, names) = substituteArgWithNames args+    processStgRhs (StgRhsClosure fvs ccs upd bndrs body typ)+      = (\(body', names) -> (StgRhsClosure fvs ccs upd bndrs body' typ, names)) <$>+        processStgExpr body++    -- Recursive expressions+    processStgExpr :: CgStgExpr -> Maybe (CgStgExpr, UniqSet Name)+    processStgExpr (StgLit _) = Nothing+    processStgExpr (StgTick _ _) = Nothing+    processStgExpr (StgLet n b e) =+      case (substituteStringLit b, processStgExpr e) of+        (Left _, Nothing) -> Nothing+        (Right (b', names), Nothing) -> Just (StgLet n b' e, names)+        (Left _, Just (e', names)) -> Just (StgLet n b e', names)+        (Right (b', names), Just (e', names')) -> Just (StgLet n b' e', names `unionUniqSets` names')+    processStgExpr (StgLetNoEscape n b e) =+      case (substituteStringLit b, processStgExpr e) of+        (Left _, Nothing) -> Nothing+        (Right (b', names), Nothing) -> Just (StgLetNoEscape n b' e, names)+        (Left _, Just (e', names)) -> Just (StgLetNoEscape n b e', names)+        (Right (b', names), Just (e', names')) -> Just (StgLetNoEscape n b' e', names `unionUniqSets` names')+    -- We should keep the order: See Note [Case expression invariants]+    processStgExpr (StgCase e bndr alt_type alts) =+      case (isEmptyUniqSet names, processStgExpr e) of+        (True, Nothing) -> Nothing+        (True, Just (e', names')) -> Just (StgCase e' bndr alt_type alts, names')+        (False, Nothing) -> Just (StgCase e bndr alt_type unified, names)+        (False, Just (e', names')) -> Just (StgCase e' bndr alt_type unified, names `unionUniqSets` names')+      where+        (unified, names) = extractNames splitAlts alts++        splitAlts :: CgStgAlt -> Either CgStgAlt (CgStgAlt, UniqSet Name)+        splitAlts alt@(GenStgAlt con bndrs rhs) =+          case processStgExpr rhs of+            Nothing -> Left alt+            Just (alt', names) -> Right (GenStgAlt con bndrs alt', names)++    -- No args+    processStgExpr (StgApp _ []) = Nothing+    processStgExpr (StgConApp _ _ [] _) = Nothing+    processStgExpr (StgOpApp _ [] _) = Nothing++    -- Main targets. Preserving the order of args is important+    processStgExpr (StgApp fn args@(_:_))+      | isEmptyUniqSet names = Nothing+      | otherwise = Just (StgApp fn unified, names)+      where+        (unified, names) = substituteArgWithNames args+    processStgExpr (StgConApp dc n args@(_:_) tys)+      | isEmptyUniqSet names = Nothing+      | otherwise = Just (StgConApp dc n unified tys, names)+      where+        (unified, names) = substituteArgWithNames args+    processStgExpr (StgOpApp op args@(_:_) tys)+      | isEmptyUniqSet names = Nothing+      | otherwise = Just (StgOpApp op unified tys, names)+      where+        (unified, names) = substituteArgWithNames args++    substituteArg :: StgArg -> Either StgArg (StgArg, Name)+    substituteArg a@(StgLitArg _) = Left a+    substituteArg a@(StgVarArg i) =+      let name = idName i+      in case lookupUFM stringLits name of+        Nothing -> Left a+        Just b -> Right (StgLitArg $ LitString b, name)++    substituteArgWithNames = extractNames (second (second unitUniqSet) . substituteArg)++    extractNames :: (a -> Either x (x, UniqSet Name)) -> [a] -> ([x], UniqSet Name)+    extractNames splitter target =+      let+        splitted = splitter <$> target+        combined = either (, emptyUniqSet) id <$> splitted+        unified = fst <$> combined+        names = unionManyUniqSets (snd <$> combined)+      in (unified, names)++selectStringLitsForUnfloat :: UniqSet Name -> UniqFM Name ByteString -> UniqFM Name ByteString+selectStringLitsForUnfloat usedOnceStringLits stringLits = alwaysUnfloat `plusUFM` usedOnceUnfloat+  where+    alwaysUnfloat = alwaysUnfloatStringLits stringLits+    usedOnceUnfloat = selectUsedOnceStringLits usedOnceStringLits stringLits++    alwaysUnfloatStringLits :: UniqFM Name ByteString -> UniqFM Name ByteString+    alwaysUnfloatStringLits = filterUFM $ \b -> BS.length b < STRING_LIT_MAX_LENGTH++    selectUsedOnceStringLits :: UniqSet Name -> UniqFM Name ByteString -> UniqFM Name ByteString+    selectUsedOnceStringLits usedOnceStringLits stringLits =+      stringLits `intersectUFM` getUniqSet usedOnceStringLits
compiler/GHC/SysTools/Cpp.hs view
@@ -7,6 +7,7 @@   ( doCpp   , CppOpts(..)   , getGhcVersionPathName+  , getGhcVersionIncludeFlags   , applyCDefs   , offsetIncludePaths   )@@ -21,7 +22,7 @@  import GHC.SysTools -import GHC.Unit.Env+import GHC.Unit.Env as UnitEnv import GHC.Unit.Info import GHC.Unit.State import GHC.Unit.Types@@ -31,7 +32,6 @@ import GHC.Utils.Panic  import Data.Version-import Data.List (intercalate) import Data.Maybe  import Control.Monad@@ -113,7 +113,7 @@ doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do     let hscpp_opts = picPOpts dflags     let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)-    let unit_state = ue_units unit_env+    let unit_state = ue_homeUnitState unit_env     pkg_include_dirs <- mayThrowUnitErr                         (collectIncludeDirs <$> preloadUnitsInfo unit_env)     -- MP: This is not quite right, the headers which are supposed to be installed in@@ -124,10 +124,10 @@          [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]         dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps] -    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+    let include_paths_global = map ("-I" ++)           (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs                                                     ++ concatMap includePathsGlobal dep_pkg_extra_inputs)-    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+    let include_paths_quote = map ("-iquote" ++)           (includePathsQuote cmdline_include_paths ++            includePathsQuoteImplicit cmdline_include_paths)     let include_paths = include_paths_quote ++ include_paths_global@@ -155,6 +155,9 @@     let sse_defs =           [ "-D__SSE__"      | isSseEnabled      platform ] ++           [ "-D__SSE2__"     | isSse2Enabled     platform ] +++          [ "-D__SSE3__"     | isSse3Enabled     dflags ] +++          [ "-D__SSSE3__"    | isSsse3Enabled    dflags ] +++          [ "-D__SSE4_1__"   | isSse4_1Enabled   dflags ] ++           [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]      let fma_def =@@ -175,8 +178,7 @@     let asserts_def = [ "-D__GLASGOW_HASKELL_ASSERTS_IGNORED__" | gopt Opt_IgnoreAsserts dflags]      -- Default CPP defines in Haskell source-    ghcVersionH <- getGhcVersionPathName dflags unit_env-    let hsSourceCppOpts = [ "-include", ghcVersionH ]+    ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env      -- MIN_VERSION macros     let uids = explicitUnits unit_state@@ -199,7 +201,7 @@      cpp_prog       (   map GHC.SysTools.Option verbFlags                     ++ map GHC.SysTools.Option include_paths-                    ++ map GHC.SysTools.Option hsSourceCppOpts+                    ++ map GHC.SysTools.Option ghcVersionH                     ++ map GHC.SysTools.Option target_defs                     ++ map GHC.SysTools.Option backend_defs                     ++ map GHC.SysTools.Option th_defs@@ -262,28 +264,32 @@       _         -> error "take3"     (major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0" +getGhcVersionIncludeFlags :: DynFlags -> UnitEnv -> IO [String]+getGhcVersionIncludeFlags dflags unit_env =+  getGhcVersionPathName dflags unit_env >>= \case+    Nothing -> pure []+    Just path -> pure [ "-include", path ]  -- | Find out path to @ghcversion.h@ file-getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath-getGhcVersionPathName dflags unit_env = do-  let candidates = case ghcVersionFile dflags of-        -- the user has provided an explicit `ghcversion.h` file to use.-        Just path -> [path]-        -- otherwise, try to find it in the rts' include-dirs.-        -- Note: only in the RTS include-dirs! not all preload units less we may-        -- use a wrong file. See #25106 where a globally installed-        -- /usr/include/ghcversion.h file was used instead of the one provided-        -- by the rts.-        Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of-          Nothing   -> []-          Just info -> (</> "ghcversion.h") <$> collectIncludeDirs [info]--  found <- filterM doesFileExist candidates-  case found of-      []    -> throwGhcExceptionIO (InstallationError-                                    ("ghcversion.h missing; tried: "-                                      ++ intercalate ", " candidates))-      (x:_) -> return x+getGhcVersionPathName :: DynFlags -> UnitEnv -> IO (Maybe FilePath)+getGhcVersionPathName dflags unit_env = case ghcVersionFile dflags of+  -- the user has provided an explicit `ghcversion.h` file to use.+  Just path -> doesFileExist path >>= \case+    True -> return (Just path)+    False -> throwGhcExceptionIO (InstallationError ("ghcversion.h not found in: " ++ path))+  -- otherwise, try to find it in the rts' include-dirs.+  -- Note: only in the RTS include-dirs! not all preload units less we may+  -- use a wrong file. See #25106 where a globally installed+  -- /usr/include/ghcversion.h file was used instead of the one provided+  -- by the rts.+  Nothing -> case lookupUnitId (ue_homeUnitState unit_env) rtsUnitId of+    Nothing   -> pure Nothing+    Just info -> do+      let candidates = (</> "ghcversion.h") <$> collectIncludeDirs [info]+      found <- filterM doesFileExist candidates+      case found of+        [] -> pure Nothing+        (x:_) -> pure (Just x)  applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] applyCDefs NoCDefs _ _ = return []
compiler/GHC/SysTools/Process.hs view
@@ -6,7 +6,14 @@ -- (c) The GHC Team 2017 -- ------------------------------------------------------------------------------module GHC.SysTools.Process where+module GHC.SysTools.Process+  ( readCreateProcessWithExitCode'+  , getGccEnv+  , runSomething+  , runSomethingResponseFile+  , runSomethingFiltered+  , runSomethingWith+  ) where  import GHC.Prelude @@ -22,6 +29,14 @@ import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) import GHC.Data.FastString +import GHC.IO.Encoding++#if defined(__IO_MANAGER_WINIO__)+import GHC.IO.SubSystem ((<!>))+import GHC.IO.Handle.Windows (handleToHANDLE)+import GHC.Event.Windows (associateHandle')+#endif+ import Control.Concurrent import Data.Char @@ -36,20 +51,8 @@ -- | Enable process jobs support on Windows if it can be expected to work (e.g. -- @process >= 1.6.9.0@). enableProcessJobs :: CreateProcess -> CreateProcess-#if defined(MIN_VERSION_process) enableProcessJobs opts = opts { use_process_jobs = True }-#else-enableProcessJobs opts = opts-#endif -#if !MIN_VERSION_base(4,15,0)--- TODO: This can be dropped with GHC 8.16-hGetContents' :: Handle -> IO String-hGetContents' hdl = do-  output  <- hGetContents hdl-  _ <- evaluate $ length output-  return output-#endif  -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is -- inherited from the parent process, and output to stderr is not captured.@@ -80,26 +83,6 @@      return (ex, output) -replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]-replaceVar (var, value) env =-    (var, value) : filter (\(var',_) -> var /= var') env---- | Version of @System.Process.readProcessWithExitCode@ that takes a--- key-value tuple to insert into the environment.-readProcessEnvWithExitCode-    :: String -- ^ program path-    -> [String] -- ^ program args-    -> (String, String) -- ^ addition to the environment-    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)-readProcessEnvWithExitCode prog args env_update = do-    current_env <- getEnvironment-    readCreateProcessWithExitCode (proc prog args) {-        env = Just (replaceVar env_update current_env) } ""---- Don't let gcc localize version info string, #8825-c_locale_env :: (String, String)-c_locale_env = ("LANGUAGE", "C")- -- If the -B<dir> option is set, add <dir> to PATH.  This works around -- a bug in gcc on Windows Vista where it can't find its auxiliary -- binaries (see bug #1110).@@ -153,7 +136,7 @@   :: Logger   -> TmpFs   -> TempDir-  -> (String->String)+  -> ([String] -> [String])   -> String   -> String   -> [Option]@@ -199,7 +182,7 @@         ]  runSomethingFiltered-  :: Logger -> (String->String) -> String -> String -> [Option]+  :: Logger -> ([String] -> [String]) -> String -> String -> [Option]   -> Maybe FilePath -> Maybe [(String,String)] -> IO ()  runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env =@@ -236,18 +219,26 @@       throwGhcExceptionIO $         InstallationError (phase_name ++ ": could not execute: " ++ pgm) +withPipe :: ((Handle, Handle) -> IO a) -> IO a+withPipe = bracket createPipe $ \ (readEnd, writeEnd) -> do+  hClose readEnd+  hClose writeEnd -builderMainLoop :: Logger -> (String -> String) -> FilePath+builderMainLoop :: Logger -> ([String] -> [String]) -> FilePath                 -> [String] -> Maybe FilePath -> Maybe [(String, String)]                 -> IO ExitCode-builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do-  chan <- newChan+builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (readEnd, writeEnd) -> do +#if defined(__IO_MANAGER_WINIO__)+  return () <!> do+    associateHandle' =<< handleToHANDLE readEnd+#endif+   -- We use a mask here rather than a bracket because we want   -- to distinguish between cleaning up with and without an   -- exception. This is to avoid calling terminateProcess   -- unless an exception was raised.-  let safely inner = mask $ \restore -> do+  mask $ \restore -> do         -- acquire         -- On Windows due to how exec is emulated the old process will exit and         -- a new process will be created. This means waiting for termination of@@ -257,105 +248,86 @@         -- finish.         let procdata =               enableProcessJobs-              $ (proc pgm real_args) { cwd = mb_cwd-                                     , env = mb_env-                                     , std_in  = CreatePipe-                                     , std_out = CreatePipe-                                     , std_err = CreatePipe-                                     }-        (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $+              $ (proc pgm real_args) {+                cwd = mb_cwd+              , env = mb_env+              , std_in  = CreatePipe++              -- We used to treat stdout/stderr as separate streams, but this+              -- was racy (see #25517).  We now treat them as one stream and+              -- that is fine for our use-case.  We rely on upstream programs+              -- to serialize writes to the two streams appropriately (note+              -- that they already need to do that to produce deterministic+              -- output when used interactively / on the command-line).+              , std_out = UseHandle writeEnd+              , std_err = UseHandle writeEnd+              }+        (Just hStdIn, Nothing, Nothing, hProcess) <- restore $           createProcess_ "builderMainLoop" procdata-        let cleanup_handles = do-              hClose hStdIn-              hClose hStdOut-              hClose hStdErr+        hClose writeEnd         r <- try $ restore $ do-          hSetBuffering hStdOut LineBuffering-          hSetBuffering hStdErr LineBuffering-          let make_reader_proc h = forkIO $ readerProc chan h filter_fn-          bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->-            bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->-            inner hProcess+          getLocaleEncoding >>= hSetEncoding readEnd+          hSetNewlineMode readEnd nativeNewlineMode+          hSetBuffering readEnd LineBuffering+          messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd+          mapM_ processBuildMessage messages+          waitForProcess hProcess+        hClose hStdIn         case r of-          -- onException           Left (SomeException e) -> do             terminateProcess hProcess-            cleanup_handles             throw e-          -- cleanup when there was no exception           Right s -> do-            cleanup_handles             return s-  safely $ \h -> do-    -- we don't want to finish until 2 streams have been complete-    -- (stdout and stderr)-    log_loop chan (2 :: Integer)-    -- after that, we wait for the process to finish and return the exit code.-    waitForProcess h   where-    -- t starts at the number of streams we're listening to (2) decrements each-    -- time a reader process sends EOF. We are safe from looping forever if a-    -- reader thread dies, because they send EOF in a finally handler.-    log_loop _ 0 = return ()-    log_loop chan t = do-      msg <- readChan chan+    processBuildMessage :: BuildMessage -> IO ()+    processBuildMessage msg = do       case msg of         BuildMsg msg -> do           logInfo logger $ withPprStyle defaultUserStyle msg-          log_loop chan t         BuildError loc msg -> do           logMsg logger errorDiagnostic (mkSrcSpan loc loc)               $ withPprStyle defaultUserStyle msg-          log_loop chan t-        EOF ->-          log_loop chan  (t-1) -readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()-readerProc chan hdl filter_fn =-    (do str <- hGetContents hdl-        loop (linesPlatform (filter_fn str)) Nothing)-    `finally`-       writeChan chan EOF-        -- ToDo: check errors more carefully-        -- ToDo: in the future, the filter should be implemented as-        -- a stream transformer.+parseBuildMessages :: [String] -> [BuildMessage]+parseBuildMessages str = loop str Nothing     where-        loop []     Nothing    = return ()-        loop []     (Just err) = writeChan chan err+        loop :: [String] -> Maybe BuildMessage -> [BuildMessage]+        loop []     Nothing    = []+        loop []     (Just err) = [err]         loop (l:ls) in_err     =                 case in_err of                   Just err@(BuildError srcLoc msg)                     | leading_whitespace l ->                         loop ls (Just (BuildError srcLoc (msg $$ text l)))-                    | otherwise -> do-                        writeChan chan err-                        checkError l ls+                    | otherwise ->+                        err : checkError l ls                   Nothing ->                         checkError l ls-                  _ -> panic "readerProc/loop"+                  _ -> panic "parseBuildMessages/loop" +        checkError :: String -> [String] -> [BuildMessage]         checkError l ls            = case parseError l of-                Nothing -> do-                    writeChan chan (BuildMsg (text l))-                    loop ls Nothing-                Just (file, lineNum, colNum, msg) -> do-                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum+                Nothing ->+                    BuildMsg (text l) : loop ls Nothing+                Just (srcLoc, msg) -> do                     loop ls (Just (BuildError srcLoc (text msg))) +        leading_whitespace :: String -> Bool         leading_whitespace []    = False         leading_whitespace (x:_) = isSpace x -parseError :: String -> Maybe (String, Int, Int, String)+parseError :: String -> Maybe (SrcLoc, String) parseError s0 = case breakColon s0 of                 Just (filename, s1) ->                     case breakIntColon s1 of                     Just (lineNum, s2) ->                         case breakIntColon s2 of                         Just (columnNum, s3) ->-                            Just (filename, lineNum, columnNum, s3)+                            Just (mkSrcLoc (mkFastString filename) lineNum columnNum, s3)                         Nothing ->-                            Just (filename, lineNum, 0, s2)+                            Just (mkSrcLoc (mkFastString filename) lineNum 0, s2)                     Nothing -> Nothing                 Nothing -> Nothing @@ -385,22 +357,3 @@ data BuildMessage   = BuildMsg   !SDoc   | BuildError !SrcLoc !SDoc-  | EOF---- Divvy up text stream into lines, taking platform dependent--- line termination into account.-linesPlatform :: String -> [String]-#if !defined(mingw32_HOST_OS)-linesPlatform ls = lines ls-#else-linesPlatform "" = []-linesPlatform xs =-  case lineBreak xs of-    (as,xs1) -> as : linesPlatform xs1-  where-   lineBreak "" = ("","")-   lineBreak ('\r':'\n':xs) = ([],xs)-   lineBreak ('\n':xs) = ([],xs)-   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)--#endif
compiler/GHC/SysTools/Tasks.hs view
@@ -7,7 +7,26 @@ -- (c) The GHC Team 2017 -- ------------------------------------------------------------------------------module GHC.SysTools.Tasks where+module GHC.SysTools.Tasks+  ( runUnlit+  , SourceCodePreprocessor(..)+  , runSourceCodePreprocessor+  , runPp+  , runCc+  , askLd+  , runAs+  , runLlvmOpt+  , runLlvmLlc+  , runLlvmAs+  , runEmscripten+  , figureLlvmVersion+  , runMergeObjects+  , runAr+  , askOtool+  , runInstallNameTool+  , runRanlib+  , runWindres+  ) where  import GHC.Prelude import GHC.ForeignSrcLang@@ -63,8 +82,8 @@ augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)  -- | Discard some harmless warnings from gcc that we can't turn off-cc_filter :: String -> String-cc_filter = unlines . doFilter . lines where+cc_filter :: [String] -> [String]+cc_filter = doFilter where   {-   gcc gives warnings in chunks like so:       In file included from /foo/bar/baz.h:11,
compiler/GHC/Tc/Deriv.hs view
@@ -20,52 +20,56 @@ import GHC.Driver.Session  import GHC.Tc.Errors.Types-import GHC.Tc.Utils.Monad import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils-import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )-import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate+import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) import GHC.Tc.Validity( checkValidInstHead )-import GHC.Core.InstEnv-import GHC.Tc.Utils.Instantiate-import GHC.Core.FamInstEnv import GHC.Tc.Gen.HsType-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Ppr ( pprTyVars )-import GHC.Unit.Module.Warnings+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Env  import GHC.Rename.Bind import GHC.Rename.Env import GHC.Rename.Module ( addTcgDUs ) import GHC.Rename.Utils +import GHC.Core.TyCo.Ppr ( pprTyVars )+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv import GHC.Core.Unify( tcUnifyTy ) import GHC.Core.Class import GHC.Core.Type-import GHC.Utils.Error import GHC.Core.DataCon-import GHC.Data.Maybe+import GHC.Core.TyCon+import GHC.Core.Predicate( tyCoVarsOfTypesWellScoped )+ import GHC.Types.Hint (AssumedDerivingStrategy(..)) import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Set as NameSet-import GHC.Core.TyCon-import GHC.Tc.Utils.TcType import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set-import GHC.Builtin.Names import GHC.Types.SrcLoc++import GHC.Unit.Module.Warnings+import GHC.Builtin.Names++import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Logger-import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.Bag+import GHC.Data.Maybe import GHC.Data.BooleanFormula ( isUnsatisfied )  import Control.Monad@@ -177,7 +181,7 @@                              -- See @Note [Scoped tyvars in a TcTyCon]@ in                              -- "GHC.Core.TyCon".                            , di_clauses :: [LHsDerivingClause GhcRn]-                           , di_ctxt    :: SDoc -- ^ error context+                           , di_ctxt    :: ErrCtxtMsg -- ^ error context                            }  {-@@ -520,7 +524,7 @@              -> Maybe (LDerivStrategy GhcRn)              -> LocatedC [LHsSigType GhcRn]                 -- ^ The location refers to the @(Show, Eq)@ part of @deriving (Show, Eq)@.-             -> SDoc+             -> ErrCtxtMsg              -> TcM [EarlyDerivSpec] deriveClause rep_tc scoped_tvs mb_lderiv_strat (L loc deriv_preds) err_ctxt   = setSrcSpanA loc $@@ -575,21 +579,20 @@       , text "deriv_pred"      <+> ppr deriv_pred       , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat       , text "via_tvs"         <+> ppr via_tvs ]-    (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred-    when (cls_arg_kinds `lengthIsNot` 1) $-      failWithTc (TcRnNonUnaryTypeclassConstraint DerivClauseCtxt deriv_pred)-    let [cls_arg_kind] = cls_arg_kinds-        mb_deriv_strat = fmap unLoc mb_lderiv_strat-    if (className cls == typeableClassName)-    then do warnUselessTypeable-            return Nothing-    else let deriv_tvs = via_tvs ++ cls_tvs in-         Just <$> deriveTyData tc tys mb_deriv_strat-                               deriv_tvs cls cls_tys cls_arg_kind+    mb_cls_minus1 <- tcHsDeriv deriv_pred+    case mb_cls_minus1 of+      Nothing -> return Nothing+      Just (cls, cls_tvs, arg_tys, arg_kind) ->+        do let mb_deriv_strat = fmap unLoc mb_lderiv_strat+           if className cls == typeableClassName+           then do warnUselessTypeable+                   return Nothing+           else let deriv_tvs = via_tvs ++ cls_tvs in+                Just <$> deriveTyData tc tys mb_deriv_strat+                                      deriv_tvs cls arg_tys arg_kind -{--Note [Don't typecheck too much in DerivingVia]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Don't typecheck too much in DerivingVia]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following example:    data D = ...@@ -692,7 +695,7 @@ -- a no-op nowadays. deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mode))   = setSrcSpanA loc                       $-    addErrCtxt (standaloneCtxt deriv_ty)  $+    addErrCtxt (StandaloneDerivCtxt deriv_ty)  $     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)        ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True        ; traceTc "Deriving strategy (standalone deriving)" $@@ -723,12 +726,12 @@                    inst_ty_kind = typeKind inst_ty                    mb_match     = tcUnifyTy inst_ty_kind via_kind -               checkTc (isJust mb_match)-                       (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $-                          DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)+               kind_subst <- checkJustTc+                 ( TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $+                   DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind )+                   mb_match -               let Just kind_subst = mb_match-                   ki_subst_range  = getSubstRangeTyCoFVs kind_subst+               let ki_subst_range  = getSubstRangeTyCoFVs kind_subst                    -- See Note [Unification of two kind variables in deriving]                    unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst                                         && not (v `elemVarSet` ki_subst_range))@@ -853,9 +856,10 @@                , text "tycon:" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc)                , text "cls_arg:" <+> ppr (mkTyConApp tc tc_args_to_keep) <+> dcolon <+> ppr inst_ty_kind                , text "cls_arg_kind:" <+> ppr cls_arg_kind ]-        ; checkTc (enough_args && isJust mb_match)-                  (TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $-                     DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep)+        ; kind_subst <- checkJustTc+            ( TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $+              DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep )+            ( guard enough_args *> mb_match )          ; let -- Returns a singleton-element list if using ViaStrategy and an               -- empty list otherwise. Useful for free-variable calculations.@@ -883,7 +887,6 @@         ; let tkvs = scopedSort $ fvVarList $                      unionFV (tyCoFVsOfTypes tc_args_to_keep)                              (FV.mkFVs deriv_tvs)-              Just kind_subst = mb_match               (tkvs', cls_tys', tc_args', mb_deriv_strat')                 = propagate_subst kind_subst tkvs cls_tys                                   tc_args_to_keep mb_deriv_strat@@ -899,11 +902,11 @@                               = typeKind (mkTyConApp tc tc_args')                     via_match = tcUnifyTy inst_ty_kind via_kind -                checkTc (isJust via_match)-                        (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $-                           DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)+                via_subst <- checkJustTc+                  ( TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $+                    DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind )+                    via_match -                let Just via_subst = via_match                 pure $ propagate_subst via_subst tkvs' cls_tys'                                        tc_args' mb_deriv_strat' @@ -1429,13 +1432,13 @@ -- EarlyDerivSpec from it. mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec mk_eqn_from_mechanism mechanism-  = do DerivEnv { denv_overlap_mode = overlap_mode-                , denv_tvs          = tvs-                , denv_cls          = cls-                , denv_inst_tys     = inst_tys-                , denv_ctxt         = deriv_ctxt-                , denv_skol_info    = skol_info-                , denv_warn         = warn } <- ask+  = do env@(DerivEnv { denv_overlap_mode = overlap_mode+                     , denv_tvs          = tvs+                     , denv_cls          = cls+                     , denv_inst_tys     = inst_tys+                     , denv_ctxt         = deriv_ctxt+                     , denv_skol_info    = skol_info+                     , denv_warn         = warn }) <- ask        user_ctxt <- askDerivUserTypeCtxt        doDerivInstErrorChecks1 mechanism        loc       <- lift getSrcSpanM@@ -1443,7 +1446,7 @@        case deriv_ctxt of         InferContext wildcard ->           do { (inferred_constraints, tvs', inst_tys', mechanism')-                 <- inferConstraints mechanism+                 <- inferConstraints mechanism env              ; return $ InferTheta $ DS                    { ds_loc = loc                    , ds_name = dfun_name, ds_tvs = tvs'@@ -2350,6 +2353,3 @@       = if isDerivSpecNewtype mechanism then YesGeneralizedNewtypeDeriving                                         else NoGeneralizedNewtypeDeriving -standaloneCtxt :: LHsSigWcType GhcRn -> SDoc-standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")-                       2 (quotes (ppr ty))
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-}  -- | The deriving code for the Functor, Foldable, and Traversable classes module GHC.Tc.Deriv.Functor@@ -43,7 +44,10 @@ import GHC.Types.Var.Set import GHC.Types.Id.Make (coerceId) import GHC.Builtin.Types (true_RDR, false_RDR)+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf +import Data.Foldable import Data.Maybe (catMaybes, isJust)  {-@@ -181,7 +185,7 @@      fmap_eqns = map fmap_eqn data_cons -    ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))+    ft_fmap :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs))     ft_fmap = FT { ft_triv = \x -> pure x                    -- fmap f x = x                  , ft_var  = \x -> pure $ nlHsApp f_Expr x@@ -220,7 +224,7 @@      replace_eqns = map replace_eqn data_cons -    ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))+    ft_replace :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs))     ft_replace = FT { ft_triv = \x -> pure x                    -- p <$ x = x                  , ft_var  = \_ -> pure z_Expr@@ -600,27 +604,23 @@     -- The kind checks have ensured the last type parameter is of kind *.  -- Make a HsLam using a fresh variable from a State monad-mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))-            -> State [RdrName] (LHsExpr GhcPs)+mkSimpleLam :: (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs))+            -> State (Infinite RdrName) (LHsExpr GhcPs) -- (mkSimpleLam fn) returns (\x. fn(x)) mkSimpleLam lam =-    get >>= \case-      n:names -> do+    get >>= \ (Inf n names) -> do         put names         body <- lam (nlHsVar n)         return (mkHsLam (noLocA [nlVarPat n]) body)-      _ -> panic "mkSimpleLam"  mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs-             -> State [RdrName] (LHsExpr GhcPs))-             -> State [RdrName] (LHsExpr GhcPs)+             -> State (Infinite RdrName) (LHsExpr GhcPs))+             -> State (Infinite RdrName) (LHsExpr GhcPs) mkSimpleLam2 lam =-    get >>= \case-      n1:n2:names -> do+    get >>= \ (n1 `Inf` n2 `Inf` names) -> do         put names         body <- lam (nlHsVar n1) (nlHsVar n2)         return (mkHsLam (noLocA [nlVarPat n1,nlVarPat n2]) body)-      _ -> panic "mkSimpleLam2"  -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --@@ -637,7 +637,7 @@                  -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch ctxt fold extra_pats con insides = do     let con_name = getRdrName con-    let vars_needed = takeList insides as_RDRs+    let vars_needed = takeList insides as_RDRList     let bare_pat = nlConVarPat con_name vars_needed     let pat = if null vars_needed           then bare_pat@@ -673,7 +673,7 @@                   -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch2 ctxt fold extra_pats con insides = do     let con_name = getRdrName con-        vars_needed = takeList insides as_RDRs+        vars_needed = takeList insides (toList as_RDRs)         pat = nlConVarPat con_name vars_needed         -- Make sure to zip BEFORE invoking catMaybes. We want the variable         -- indices in each expression to match up with the argument indices@@ -684,13 +684,13 @@         -- with the same index has a type which mentions the last type         -- variable.         argTysTyVarInfo = map isJust insides-        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars+        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo (toList as_Vars)          con_expr           | null asWithTyVar = nlHsApps con_name asWithoutTyVar           | otherwise =-              let bs   = filterByList  argTysTyVarInfo bs_RDRs-                  vars = filterByLists argTysTyVarInfo bs_Vars as_Vars+              let bs   = filterByList  argTysTyVarInfo bs_RDRList+                  vars = filterByLists argTysTyVarInfo bs_VarList as_VarList               in mkHsLam (noLocA (map nlVarPat bs)) (nlHsApps con_name vars)      rhs <- fold con_expr exps@@ -887,7 +887,7 @@     -- Yields 'Just' an expression if we're folding over a type that mentions     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.     -- See Note [FFoldType and functorLikeTraverse]-    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))+    ft_foldr :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs)))     ft_foldr       = FT { ft_triv    = return Nothing              -- foldr f = \x z -> z@@ -922,7 +922,7 @@         mkFoldr = foldr nlHsApp z      -- See Note [FFoldType and functorLikeTraverse]-    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))+    ft_foldMap :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs)))     ft_foldMap       = FT { ft_triv = return Nothing              -- foldMap f = \x -> mempty@@ -949,15 +949,14 @@       where         -- mappend v1 (mappend v2 ..)         mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs-        mkFoldMap [] = mempty_Expr-        mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs+        mkFoldMap = foldr1WithDefault mempty_Expr (\x y -> nlHsApps mappend_RDR [x,y])      -- See Note [FFoldType and functorLikeTraverse]     -- Yields NullM an expression if we're folding over an expression     -- that may or may not be null. Yields IsNull if it's certainly     -- null, and yields NotNull if it's certainly not null.     -- See Note [Deriving null]-    ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))+    ft_null :: FFoldType (State (Infinite RdrName) (NullM (LHsExpr GhcPs)))     ft_null       = FT { ft_triv = return IsNull              -- null = \_ -> True@@ -998,8 +997,7 @@       where         -- v1 && v2 && ..         mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs-        mkNull [] = true_Expr-        mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs+        mkNull = foldr1WithDefault true_Expr (\x y -> nlHsApps and_RDR [x,y])  data NullM a =     IsNull   -- Definitely null@@ -1082,7 +1080,7 @@     -- Yields 'Just' an expression if we're folding over a type that mentions     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.     -- See Note [FFoldType and functorLikeTraverse]-    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))+    ft_trav :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs)))     ft_trav       = FT { ft_triv    = return Nothing              -- traverse f = pure x@@ -1140,13 +1138,21 @@ f_RDR = mkVarUnqual (fsLit "f") z_RDR = mkVarUnqual (fsLit "z") -as_RDRs, bs_RDRs :: [RdrName]-as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]-bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]+as_RDRs, bs_RDRs :: Infinite RdrName+as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- Inf.enumFrom (1::Int) ]+bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- Inf.enumFrom (1::Int) ] -as_Vars, bs_Vars :: [LHsExpr GhcPs]-as_Vars = map nlHsVar as_RDRs-bs_Vars = map nlHsVar bs_RDRs+as_Vars, bs_Vars :: Infinite (LHsExpr GhcPs)+as_Vars = fmap nlHsVar as_RDRs+bs_Vars = fmap nlHsVar bs_RDRs++as_RDRList, bs_RDRList :: [RdrName]+as_RDRList = Inf.toList as_RDRs+bs_RDRList = Inf.toList bs_RDRs++as_VarList, bs_VarList :: [LHsExpr GhcPs]+as_VarList = Inf.toList as_Vars+bs_VarList = Inf.toList bs_Vars  f_Pat, z_Pat :: LPat GhcPs f_Pat = nlVarPat f_RDR
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -263,7 +263,7 @@     ------------------------------------------------------------------     nested_eq_expr []  [] [] = true_Expr     nested_eq_expr tys as bs-      = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)+      = foldr1 and_Expr $ expectNonEmpty $ zipWith3Equal nested_eq tys as bs       -- Using 'foldr1' here ensures that the derived code is correctly       -- associated. See #10859.       where@@ -914,7 +914,7 @@           (noLocA [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed]) $         noLocA (mkHsComp ListComp stmts con_expr)       where-        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed+        stmts = zipWith3Equal mk_qual as_needed bs_needed cs_needed          mk_qual a b c = noLocA $ mkPsBindStmt noAnn (nlVarPat c)                                  (nlHsApp (nlHsVar range_RDR)@@ -955,8 +955,8 @@              -- If the product type has no fields, inRange is trivially true              -- (see #12853).              then true_Expr-             else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range-                    as_needed bs_needed cs_needed)+             else foldl1 and_Expr $ expectNonEmpty $+                  zipWith3Equal in_range as_needed bs_needed cs_needed       where         in_range a b c           = nlHsApps inRange_RDR [mkLHsVarTuple [a,b] noAnn, nlHsVar c]@@ -1055,9 +1055,9 @@         rhs | null data_cons -- See Note [Read for empty data types]             = nlHsVar pfail_RDR             | otherwise-            = nlHsApp (nlHsVar parens_RDR)-                      (foldr1 mk_alt (read_nullary_cons ++-                                      read_non_nullary_cons))+            = nlHsApp (nlHsVar parens_RDR) $+              foldr1 mk_alt $ expectNonEmpty $+              read_nullary_cons ++ read_non_nullary_cons      read_non_nullary_cons = map read_non_nullary_con non_nullary_cons @@ -1117,7 +1117,7 @@             ++ concat (intersperse [read_punc ","] field_stmts)             ++ [read_punc "}"] -        field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed+        field_stmts  = zipWithEqual read_field labels as_needed          con_arity    = dataConSourceArity data_con         labels       = map (field_label . flLabel) $ dataConFieldLabels data_con@@ -1125,7 +1125,7 @@         is_infix     = dataConIsInfix data_con         is_record    = labels `lengthExceeds` 0         as_needed    = take con_arity as_RDRs-        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (derivDataConInstArgTys data_con dit)+        read_args    = zipWithEqual read_arg as_needed (derivDataConInstArgTys data_con dit)         (read_a1:read_a2:_) = read_args          prefix_prec = appPrecedence@@ -1269,7 +1269,7 @@                  where                    nm       = wrapOpParens (unpackFS l) -             show_args               = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys+             show_args               = zipWithEqual show_arg bs_needed arg_tys              (show_arg1:show_arg2:_) = show_args              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args @@ -1278,8 +1278,7 @@              show_record_args = concat $                                 intersperse [comma_space] $                                 [ [show_label lbl, arg]-                                | (lbl,arg) <- zipEqual "gen_Show_binds"-                                                        labels show_args ]+                                | (lbl,arg) <- zipEqual labels show_args ]               show_arg :: RdrName -> Type -> LHsExpr GhcPs              show_arg b arg_ty@@ -1407,7 +1406,7 @@      gfoldl_eqn con       = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],-                   foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed)+                   foldl' mk_k_app (z_Expr `nlHsApp` (nlHsVar (getRdrName con))) as_needed)                    where                      con_name ::  RdrName                      con_name = getRdrName con@@ -1427,18 +1426,9 @@      gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)     mk_unfold_rhs dc = foldr nlHsApp-                           (z_Expr `nlHsApp` (eta_expand_data_con dc))+                           (z_Expr `nlHsApp` (nlHsVar (getRdrName dc)))                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) -    eta_expand_data_con dc =-        mkHsLam (noLocA eta_expand_pats)-          (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)-      where-        eta_expand_pats = map nlVarPat eta_expand_vars-        eta_expand_hsvars = map nlHsVar eta_expand_vars-        eta_expand_vars = take (dataConSourceArity dc) as_RDRs--     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid                         -- redundant test, and annoying warning       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor@@ -1634,14 +1624,14 @@     ==>      instance (Lift a) => Lift (Foo a) where-        lift (Foo a) = [| Foo $(lift a) |]-        lift ((:^:) u v) = [| (:^:) $(lift u) $(lift v) |]+        lift (Foo a) = ConE 'Foo `appE` (lift a)+        lift ((:^:) u v) = ConE '(:^:) `appE` (lift u) `appE` (lift v) -        liftTyped (Foo a) = [|| Foo $$(liftTyped a) ||]-        liftTyped ((:^:) u v) = [|| (:^:) $$(liftTyped u) $$(liftTyped v) ||]+        liftTyped (Foo a) = unsafeCodeCoerce (ConE 'Foo `appE` (lift a))+        liftTyped ((:^:) u v) = unsafeCodeCoerce (ConE '(:^:) `appE` (lift u) `appE` (lift v)) -Note that we use explicit splices here in order to not trigger the implicit-lifting warning in derived code. (See #20688)+Note that we use variable quotes, in order to avoid the constructor being+lifted by implicit cross-stage lifting when `-XNoImplicitStagePersistence` is enabled. -}  @@ -1651,33 +1641,37 @@   ([lift_bind, liftTyped_bind], emptyBag)   where     lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)-                                 (map (pats_etc mk_untyped_bracket mk_usplice liftName) data_cons)+                                 (map (pats_etc mk_untyped_bracket ) data_cons)     liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)-                                 (map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons)+                                 (map (pats_etc mk_typed_bracket ) data_cons) -    mk_untyped_bracket = HsUntypedBracket noExtField . ExpBr noAnn-    mk_typed_bracket = HsTypedBracket noAnn+    mk_untyped_bracket = id+    mk_typed_bracket = nlHsApp unsafeCodeCoerce_Expr -    mk_tsplice = HsTypedSplice noAnn-    mk_usplice = HsUntypedSplice noExtField . HsUntypedSpliceExpr noAnn     data_cons = getPossibleDataCons tycon tycon_args -    pats_etc mk_bracket mk_splice lift_name data_con++    pats_etc :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> DataCon -> ([LPat GhcPs], LHsExpr GhcPs)+    pats_etc mk_bracket data_con       = ([con_pat], lift_Expr)        where             con_pat      = nlConVarPat data_con_RDR as_needed             data_con_RDR = getRdrName data_con             con_arity    = dataConSourceArity data_con             as_needed    = take con_arity as_RDRs-            lift_Expr    = noLocA (mk_bracket br_body)-            br_body      = nlHsApps (Exact (dataConName data_con))-                                    (map lift_var as_needed)+            lift_Expr    = mk_bracket finish+            con_brack :: LHsExpr GhcPs+            con_brack    = nlHsApps (Exact conEName)+                            [noLocA $ HsUntypedBracket noExtField+                              $ VarBr noSrcSpanA True (noLocA (Exact (dataConName data_con)))] +            finish = foldl' (\b1 b2 -> nlHsApps (Exact appEName) [b1, b2]) con_brack (map lift_var as_needed)+             lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)-            lift_var x   = noLocA (mk_splice (nlHsPar (mk_lift_expr x)))+            lift_var x   = nlHsPar (mk_lift_expr x)              mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)-            mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x]+            mk_lift_expr x = nlHsApps (Exact liftName) [nlHsVar x]  {- ************************************************************************@@ -2136,7 +2130,7 @@     hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s  nlHsCoreTy :: HsCoreTy -> LHsType GhcPs-nlHsCoreTy = noLocA . XHsType+nlHsCoreTy = noLocA . XHsType . HsCoreTy  mkCoerceClassMethEqn :: Class   -- the class being derived                      -> [TyVar] -- the tvs in the instance head (this includes@@ -2209,7 +2203,7 @@       where         tc_name = tyConName tycon         tc_name_string = occNameFS (getOccName tc_name)-        definition_mod_name = moduleNameFS (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))+        definition_mod_name = moduleNameFS (moduleName (expectJust $ nameModule_maybe tc_name))         rhs = nlHsVar mkDataType_RDR               `nlHsApp` nlHsLit (mkHsStringFS (concatFS [definition_mod_name, fsLit ".", tc_name_string]))               `nlHsApp` nlList (map nlHsVar dataC_RDRs)@@ -2253,10 +2247,10 @@ genAuxBindSpecSig loc spec = case spec of   DerivTag2Con tycon _     -> mk_sig $ L (noAnnSrcSpan loc) $-       XHsType $ mkSpecForAllTys (tyConTyVars tycon) $+       XHsType $ HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $        intTy `mkVisFunTyMany` mkParentType tycon   DerivMaxTag _ _-    -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))+    -> mk_sig (L (noAnnSrcSpan loc) (XHsType (HsCoreTy intTy)))   DerivDataDataType _ _ _     -> mk_sig (nlHsTyVar NotPromoted dataType_RDR)   DerivDataConstr _ _ _@@ -2528,20 +2522,21 @@ showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2  nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs--nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty-nested_compose_Expr [e] = parenify e-nested_compose_Expr (e:es)-  = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)+nested_compose_Expr =+  nlHsLam . mkSimpleMatch (LamAlt LamSingle) (noLocA [z_Pat]) . go+  where+    -- Previously we used (`.`), but inlining its definition improves compiler+    -- performance significantly since we no longer need to typecheck lots of+    -- (.) applications (each which needed three type applications, all @String)+    -- (See #25453 for why this is especially slow currently)+    go []  = panic "nested_compose_expr"   -- Arg is always non-empty+    go [e] = nlHsApp e z_Expr+    go (e:es) = nlHsApp e (go es)  -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! error_Expr :: FastString -> LHsExpr GhcPs error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsStringFS string))--parenify :: LHsExpr GhcPs -> LHsExpr GhcPs-parenify e@(L _ (HsVar _ _)) = e-parenify e                   = mkHsPar e  -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it.
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -67,8 +67,7 @@  import Control.Monad (mplus) import Data.List (zip4, partition)-import qualified Data.List as Partial (last)-import Data.List.NonEmpty (nonEmpty)+import Data.List.NonEmpty (NonEmpty (..), last, nonEmpty) import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) @@ -351,8 +350,7 @@                                   $ getTyVar last_dc_inst_univ   where     dc_inst_univs = dataConInstUnivs dc tc_args-    last_dc_inst_univ = assert (not (null dc_inst_univs)) $-                        Partial.last dc_inst_univs+    last_dc_inst_univ = last $ expectNonEmpty dc_inst_univs   -- Bindings for the Generic instance@@ -378,7 +376,7 @@              | otherwise  = False              where                cons       = length datacons-               max_fields = maximum $ map dataConSourceArity datacons+               max_fields = maximum $ 0 :| map dataConSourceArity datacons             inline1 f = L loc'' . InlineSig noAnn (L loc' f)                      $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 }@@ -612,7 +610,7 @@                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]          arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type-        arg gk_ t (HsSrcBang _ (HsBang su ss)) ib fl = mkS fl su ss ib $ case gk_ of+        arg gk_ t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of             -- Here we previously used Par0 if t was a type variable, but we             -- realized that we can't always guarantee that we are wrapping-up             -- all type variables in Par0. So we decided to stop using Par0
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -17,6 +17,7 @@ import GHC.Prelude  import GHC.Tc.Deriv.Utils+import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) ) import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor@@ -26,7 +27,8 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint import GHC.Tc.Utils.TcType-import GHC.Tc.Solver+import GHC.Tc.Solver( simplifyTopImplic )+import GHC.Tc.Solver.Solve( solveWanteds ) import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor)@@ -43,9 +45,8 @@  import GHC.Data.Pair import GHC.Builtin.Names-import GHC.Builtin.Types (typeToTypeKind)+import GHC.Builtin.Types (mkConstraintTupleTy, typeToTypeKind) -import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc@@ -65,7 +66,7 @@  ---------------------- -inferConstraints :: DerivSpecMechanism+inferConstraints :: DerivSpecMechanism -> DerivEnv                  -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) -- inferConstraints figures out the constraints needed for the -- instance declaration generated by a 'deriving' clause on a@@ -82,12 +83,12 @@ -- Generate a sufficiently large set of constraints that typechecking the -- generated method definitions should succeed.   This set will be simplified -- before being used in the instance declaration-inferConstraints mechanism-  = do { DerivEnv { denv_tvs      = tvs-                  , denv_cls      = main_cls-                  , denv_inst_tys = inst_tys } <- ask-       ; wildcard <- isStandaloneWildcardDeriv-       ; let infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)+inferConstraints mechanism (DerivEnv { denv_ctxt     = ctxt+                                     , denv_tvs      = tvs+                                     , denv_cls      = main_cls+                                     , denv_inst_tys = inst_tys })+  = do { let wildcard = isStandaloneWildcardDeriv ctxt+             infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)              infer_constraints =                case mechanism of                  DerivSpecStock{dsm_stock_dit = dit}@@ -168,12 +169,12 @@                                         , dit_tc_args     = tc_args                                         , dit_rep_tc      = rep_tc                                         , dit_rep_tc_args = rep_tc_args })-  = do DerivEnv { denv_tvs      = tvs+  = do DerivEnv { denv_ctxt     = ctxt+                , denv_tvs      = tvs                 , denv_cls      = main_cls                 , denv_inst_tys = inst_tys } <- ask-       wildcard <- isStandaloneWildcardDeriv--       let inst_ty    = mkTyConApp tc tc_args+       let wildcard   = isStandaloneWildcardDeriv ctxt+           inst_ty    = mkTyConApp tc tc_args            tc_binders = tyConBinders rep_tc            choose_level bndr              | isNamedTyConBinder bndr = KindLevel@@ -296,7 +297,7 @@               = map $ \ty -> let ki = typeKind ty in                              ( [ mk_cls_pred orig t_or_k cls ty                                , SimplePredSpec-                                   { sps_pred = mkPrimEqPred ki typeToTypeKind+                                   { sps_pred = mkNomEqPred ki typeToTypeKind                                    , sps_origin = orig                                    , sps_type_or_kind = KindLevel                                    }@@ -369,13 +370,14 @@ -- derived instance context. inferConstraintsAnyclass :: DerivM ThetaSpec inferConstraintsAnyclass-  = do { DerivEnv { denv_cls       = cls+  = do { DerivEnv { denv_ctxt      = ctxt+                  , denv_cls       = cls                   , denv_inst_tys  = inst_tys } <- ask        ; let gen_dms = [ (sel_id, dm_ty)                        | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]-       ; wildcard <- isStandaloneWildcardDeriv -       ; let meth_pred :: (Id, Type) -> PredSpec+       ; let wildcard = isStandaloneWildcardDeriv ctxt+             meth_pred :: (Id, Type) -> PredSpec                -- (Id,Type) are the selector Id and the generic default method type                -- NB: the latter is /not/ quantified over the class variables                -- See Note [Gathering and simplifying constraints for DeriveAnyClass]@@ -407,46 +409,64 @@ inferConstraintsCoerceBased :: [Type] -> Type                             -> DerivM ThetaSpec inferConstraintsCoerceBased cls_tys rep_ty = do-  DerivEnv { denv_tvs      = tvs+  DerivEnv { denv_ctxt     = ctxt+           , denv_tvs      = tvs            , denv_cls      = cls            , denv_inst_tys = inst_tys } <- ask-  sa_wildcard <- isStandaloneWildcardDeriv-  let -- The following functions are polymorphic over the representation-      -- type, since we might either give it the underlying type of a-      -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type-      -- (for DerivingVia).-      rep_tys ty  = cls_tys ++ [ty]-      rep_pred ty = mkClassPred cls (rep_tys ty)-      rep_pred_o ty = SimplePredSpec { sps_pred = rep_pred ty-                                     , sps_origin = deriv_origin-                                     , sps_type_or_kind = TypeLevel-                                     }+  let -- rep_ty might come from:+      --   GeneralizedNewtypeDeriving / DerivSpecNewtype:+      --       the underlying type of the newtype ()+      --   DerivingVia / DerivSpecVia+      --       the `via` type++      rep_pred_o = SimplePredSpec { sps_pred         = mkClassPred cls (cls_tys ++ [rep_ty])+                                  , sps_origin       = deriv_origin+                                  , sps_type_or_kind = TypeLevel+                                  }               -- rep_pred is the representation dictionary, from where               -- we are going to get all the methods for the final               -- dictionary       deriv_origin = mkDerivOrigin sa_wildcard+      sa_wildcard  = isStandaloneWildcardDeriv ctxt        -- Next we collect constraints for the class methods       -- If there are no methods, we don't need any constraints       -- Otherwise we need (C rep_ty), for the representation methods,       -- and constraints to coerce each individual method-      meth_preds :: Type -> ThetaSpec-      meth_preds ty-        | null meths = [] -- No methods => no constraints-                          -- (#12814)-        | otherwise = rep_pred_o ty : coercible_constraints ty+      meth_preds :: ThetaSpec+      meth_preds | null meths = [] -- No methods => no constraints (#12814)+                 | otherwise = rep_pred_o : coercible_constraints       meths = classMethods cls-      coercible_constraints ty++      coercible_constraints         = [ SimplePredSpec-              { sps_pred = mkReprPrimEqPred t1 t2+              { sps_pred =+                  assertPpr (tvs1 == tvs2) (ppr t1 $$ ppr t2) $+                  -- assert: mkCoerceClassMethEqn returns two+                  -- foralls with the very same forall-binders+                    tcMkDFunSigmaTy tvs2 theta2 $+                      mkConstraintTupleTy $ mkReprEqPred tau1 tau2 : theta1+                      -- The two method types (tau1, tau2) must be coercible.+                      -- Also, if there are constraints, the constraints+                      -- provided to the derived method (theta2) must be+                      -- sufficient to solve the constraints required by the+                      -- method being coerced (theta1).+                      -- See Note [Inferred contexts from method constraints]               , sps_origin = DerivOriginCoerce meth t1 t2 sa_wildcard               , sps_type_or_kind = TypeLevel               }           | meth <- meths           , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs-                                       inst_tys ty meth ]+                                       inst_tys rep_ty meth+              -- If we have class C a b c where { op :: op_ty }+              -- and inst_tys = [t1, t2, t3]+              -- then t1 = op_ty{t1,t2,rep_ty/a,b,c]+              --      t2 = op_ty{t1,t2,t3/a,b,c]+          , let (tvs1, theta1, tau1) = tcSplitSigmaTy t1+          , let (tvs2, theta2, tau2) = tcSplitSigmaTy t2+          ] -  pure (meth_preds rep_ty)+  pure meth_preds  {- Note [Inferring the instance context] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -550,7 +570,72 @@ a context for the Data instances:         instance Typeable a => Data (T a) where ... +Note [Inferred contexts from method constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the `deriving Alt` part of this example (from the passing part of+T20815a): +  class Alt f where+    some :: forall a. Applicative f => f a -> f [a]++  newtype T f a = T (f a) deriving Alt++We will produce this derived instance declaration:++  instance (Alt f, ???) => Alt (T f) where+    some :: forall a. Applicative (T f) => T f a -> T f [a]+    some @a (d1 :: Applicative (T f))+      = coerce @(f a -> f [a])+               @(T f a -> T f [a])+               (d2 :: Coercible (f a -> f [a]) (T f a -> T f [a]))+               (some @f (d3 :: Alt f) @a (d4 :: Applicative f))++(Dictionary abstractions and applications are added here even though they are+not usually visible, or even emitted in the code generated by `deriving`.)++The task of `inferConstraints` is to determine the `???` such that it will be+sufficient to solve the constraints arising from that definition of `some`. We+can write out what the type checker sees as follows:++  forall f+    [G] Alt f                -- Given+    [G] ???                  -- Given+  =>+    forall a.+      [G] Applicative (T f)  -- Also given (as d1)+    =>+      [W] Coercible (f a -> f [a]) (T f a -> T f [a])  -- Wanted (as d2)+      [W] Alt f                                        -- Wanted (as d3)+      [W] Applicative f                                -- Wanted (as d4)++`d3` is trivially provided by the given `Alt f`. The simplest way to ensure that+`d4` and `d2` can be solved is to:++* Generate this "target constraint" (in `inferConstraintsCoerceBased`):++  forall a. Applicative (T f)+    => ( Coercible (f a -> f [a]) (T f a -> T f [a])+       , Applicative f+       )++* Simplify the target constraint (in `simplifyInstanceContexts`, which in turn+  calls `simplifyDeriv`). This solves the `Coercible` constraint outright, but+  cannot solve the `Applicative f` constraint.+  See Note [Simplifying the instance context]++* The leftover, unsolved constraint (here `Applicative f`) becomes the `???` in+  the derived instance decl.++The target constraint for GND is created in `inferConstraintsCoerceBased`.++In general, the point here is that the inferred context for a derived instance+must include, for each class method with constraints, a quantified constraint+mapping the provided context for the derived method to both:+  - the `Coercible` corresponding to the monotypes of the base and derived+    methods, and+  - the needed context for the base method.++ ************************************************************************ *                                                                      *          Finding the fixed point of deriving equations@@ -714,10 +799,6 @@        -- See Note [Deterministic simplifyInstanceContexts]     canSolution = map (sortBy nonDetCmpType) -derivInstCtxt :: PredType -> SDoc-derivInstCtxt pred-  = text "When deriving the instance for" <+> parens (ppr pred)- {- *********************************************************************************** *                                                                                 *@@ -736,7 +817,7 @@                   , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs                   , ds_skol_info = skol_info, ds_user_ctxt = user_ctxt })   = setSrcSpan loc  $-    addErrCtxt (derivInstCtxt (mkClassPred clas inst_tys)) $+    addErrCtxt (DerivInstCtxt (mkClassPred clas inst_tys)) $     do {        -- See [STEP DAC BUILD]        -- Generate the implication constraints, one for each method, to solve@@ -762,9 +843,11 @@        -- See [STEP DAC HOIST]        -- From the simplified constraints extract a subset 'good' that will        -- become the context 'min_theta' for the derived instance.-       ; let residual_simple = approximateWC True solved_wanteds-             head_size       = pSizeClassPred clas inst_tys-             good = mapMaybeBag get_good residual_simple+       ; let residual_simple = approximateWC False solved_wanteds+                -- False: ignore any non-quantifiable constraints,+                --        including equalities hidden under Given equalities+             head_size = pSizeClassPred clas inst_tys+             good      = mapMaybeBag get_good residual_simple               -- Returns @Just p@ (where @p@ is the type of the Ct) if a Ct is              -- suitable to be inferred in the context of a derived instance.
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -55,23 +55,23 @@ import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface (mi_fix) -import GHC.Types.Fixity.Env (lookupFixity) import GHC.Iface.Load   (loadInterfaceForName)++import GHC.Types.Fixity.Env (lookupFixity) import GHC.Types.Name import GHC.Types.SrcLoc-import GHC.Utils.Misc import GHC.Types.Var.Set  import GHC.Builtin.Names import GHC.Builtin.Names.TH (liftClassKey) +import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Error import GHC.Utils.Unique (sameUnique)  import Control.Monad.Trans.Reader-import Data.Foldable (traverse_) import Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Data.List.SetOps (assocMaybe)@@ -92,12 +92,9 @@ -- | Is GHC processing a standalone deriving declaration with an -- extra-constraints wildcard as the context? -- (e.g., @deriving instance _ => Eq (Foo a)@)-isStandaloneWildcardDeriv :: DerivM Bool-isStandaloneWildcardDeriv = asks (go . denv_ctxt)-  where-    go :: DerivContext -> Bool-    go (InferContext wildcard) = isJust wildcard-    go (SupplyContext {})      = False+isStandaloneWildcardDeriv :: DerivContext -> Bool+isStandaloneWildcardDeriv (InferContext wildcard) = isJust wildcard+isStandaloneWildcardDeriv (SupplyContext {})      = False  -- | Return 'InstDeclCtxt' if processing with a standalone @deriving@ -- declaration or 'DerivClauseCtxt' if processing a @deriving@ clause.@@ -109,12 +106,8 @@     go (InferContext Just{})  = InstDeclCtxt True     go (InferContext Nothing) = DerivClauseCtxt --- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',--- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting. mkDerivOrigin :: Bool -> CtOrigin-mkDerivOrigin standalone_wildcard-  | standalone_wildcard = StandAloneDerivOrigin-  | otherwise           = DerivClauseOrigin+mkDerivOrigin standalone = DerivOrigin standalone  -- | Contains all of the information known about a derived instance when -- determining what its @EarlyDerivSpec@ should be.@@ -563,11 +556,19 @@     SimplePredSpec       { sps_pred :: TcPredType         -- ^ The constraint to emit as a wanted+        -- Usually just a simple predicate like (Eq a) or (ki ~# Type),+        -- but can be a forall-constraint:+        --   * in the case of GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased+        --   * if a class has quantified-constraint superclasses,+        --       via `mkDirectThetaSpec` in `inferConstraints`+       , sps_origin :: CtOrigin         -- ^ The origin of the constraint+       , sps_type_or_kind :: TypeOrKind         -- ^ Whether the constraint is a type or kind       }+   | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This     -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic     -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an@@ -677,8 +678,8 @@                   -- @deriving@ declaration   -> ThetaSpec    -- ^ The specs from which constraints will be created   -> TcM (TcLevel, WantedConstraints)-captureThetaSpecConstraints user_ctxt theta =-  pushTcLevelM $ mk_wanteds theta+captureThetaSpecConstraints user_ctxt theta+  = pushTcLevelM $ mk_wanteds theta   where     -- Create the constraints we need to solve. For stock and newtype     -- deriving, these constraints will be simple wanted constraints@@ -689,34 +690,28 @@     mk_wanteds :: ThetaSpec -> TcM WantedConstraints     mk_wanteds preds       = do { (_, wanteds) <- captureConstraints $-                             traverse_ emit_constraints preds+                             mapM_ (emitPredSpecConstraints user_ctxt) preds            ; pure wanteds } -    -- Emit the appropriate constraints depending on what sort of-    -- PredSpec we are dealing with.-    emit_constraints :: PredSpec -> TcM ()-    emit_constraints ps =-      case ps of-        -- For constraints like (C a, Ord b), emit the-        -- constraints directly as simple wanted constraints.-        SimplePredSpec { sps_pred = wanted-                       , sps_origin = orig-                       , sps_type_or_kind = t_or_k-                       } -> do-          ev <- newWanted orig (Just t_or_k) wanted-          emitSimple (mkNonCanonical ev)+emitPredSpecConstraints :: UserTypeCtxt -> PredSpec -> TcM ()+--- Emit the appropriate constraints depending on what sort of+-- PredSpec we are dealing with.+emitPredSpecConstraints _ (SimplePredSpec { sps_pred = wanted_pred+                                          , sps_origin = orig+                                          , sps_type_or_kind = t_or_k })+  = do { ev <- newWanted orig (Just t_or_k) wanted_pred+       ; emitSimple (mkNonCanonical ev) } -        -- For DeriveAnyClass, check if ty_actual is a subtype of-        -- ty_expected, which emits an implication constraint as a-        -- side effect. See-        -- Note [Gathering and simplifying constraints for DeriveAnyClass].-        -- in GHC.Tc.Deriv.Infer.-        SubTypePredSpec { stps_ty_actual   = ty_actual-                        , stps_ty_expected = ty_expected-                        , stps_origin      = orig-                        } -> do-          _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected-          return ()+emitPredSpecConstraints user_ctxt+  (SubTypePredSpec { stps_ty_actual   = ty_actual+                   , stps_ty_expected = ty_expected+                   , stps_origin      = orig })+-- For DeriveAnyClass, check if ty_actual is a subtype of ty_expected,+-- which emits an implication constraint as a side effect. See+-- Note [Gathering and simplifying constraints for DeriveAnyClass]+-- in GHC.Tc.Deriv.Infer.+  = do { _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected+       ; return () }  {- ************************************************************************@@ -927,6 +922,7 @@                                                    cond_vanilla `andCond`                                                    cond_Representable1Ok)   | sameUnique cls_key liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`+                                                   checkFlag LangExt.ImplicitStagePersistence `andCond`                                                    cond_vanilla `andCond`                                                    cond_args cls)   | otherwise                        = Nothing
compiler/GHC/Tc/Errors.hs view
@@ -1,12 +1,11 @@--{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE MultiWayIf          #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE ParallelListComp    #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiWayIf            #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE ParallelListComp      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}  module GHC.Tc.Errors(        reportUnsolved, reportAllUnsolved, warnAllUnsolved,@@ -37,10 +36,9 @@ import GHC.Tc.Zonk.TcType import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence-import GHC.Tc.Types.EvTerm import GHC.Tc.Instance.Family import GHC.Tc.Utils.Instantiate-import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit )+import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig )  import GHC.Types.Name import GHC.Types.Name.Reader@@ -61,7 +59,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCo.Ppr     ( pprTyVars )-import GHC.Core.TyCo.Tidy    ( tidyAvoiding )+import GHC.Core.TyCo.Tidy import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.DataCon@@ -267,7 +265,9 @@ important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport important ctxt doc   = SolverReport { sr_important_msg = SolverReportWithCtxt ctxt doc-                 , sr_supplementary = [] }+                 , sr_supplementary = []+                 , sr_hints         = noHints+                 }  add_relevant_bindings :: RelevantBindings -> SolverReport -> SolverReport add_relevant_bindings binds report@(SolverReport { sr_supplementary = supp })@@ -398,13 +398,6 @@  | null redundant_evs  = return () - -- Do not report redundant constraints for quantified constraints- -- See (RC4) in Note [Tracking redundant constraints]- -- Fortunately it is easy to spot implications constraints that arise- -- from quantified constraints, from their SkolInfo- | InstSkol (IsQC {}) _ <- info- = return ()-  | SigSkol user_ctxt _ _ <- info  -- When dealing with a user-written type signature,  -- we want to add "In the type signature for f".@@ -423,20 +416,16 @@                         -> TcRn ()    report_redundant_msg show_info lcl_env      = do { msg <--              mkErrorReport-                lcl_env+              mkErrorReport lcl_env                 (TcRnRedundantConstraints redundant_evs (info, show_info))-                (Just ctxt)-                []+                (Just ctxt) [] []           ; reportDiagnostic msg }  reportBadTelescope :: SolverReportErrCtxt -> CtLocEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols-  = do { msg <- mkErrorReport-                  env+  = do { msg <- mkErrorReport env                   (TcRnSolverReport report ErrorWithoutFlag)-                  (Just ctxt)-                  []+                  (Just ctxt) [] []        ; reportDiagnostic msg }   where     report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols@@ -450,10 +439,9 @@ -- See Note [Constraints to ignore]. ignoreConstraint :: Ct -> Bool ignoreConstraint ct-  | AssocFamPatOrigin <- ctOrigin ct-  = True-  | otherwise-  = False+  = case ctOrigin ct of+      AssocFamPatOrigin         -> True  -- See (CIG1)+      _                         -> False  -- | Makes an error item from a constraint, calculating whether or not -- the item should be suppressed. See Note [Wanteds rewrite Wanteds]@@ -469,13 +457,12 @@   = do { let loc = ctLoc ct              flav = ctFlavour ct -       ; (suppress, m_evdest) <- case ctEvidence ct of-         -- For this `suppress` stuff-         -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint-           CtGiven {} -> return (False, Nothing)-           CtWanted { ctev_rewriters = rewriters, ctev_dest = dest }-             -> do { rewriters' <- zonkRewriterSet rewriters-                   ; return (not (isEmptyRewriterSet rewriters'), Just dest) }+             (suppress, m_evdest) = case ctEvidence ct of+                   -- For this `suppress` stuff+                   -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint+                     CtGiven {} -> (False, Nothing)+                     CtWanted (WantedCt { ctev_rewriters = rws, ctev_dest = dest })+                                -> (not (isEmptyRewriterSet rws), Just dest)         ; let m_reason = case ct of                 CIrredCan (IrredCt { ir_reason = reason }) -> Just reason@@ -506,7 +493,7 @@                                          , text "tidy_errs =" <+> ppr tidy_errs ])           -- Catch an awkward (and probably rare) case in which /all/ errors are-         -- suppressed: see Wrinkle (WRW2) in Note [Prioritise Wanteds with empty+         -- suppressed: see Wrinkle (PER2) in Note [Prioritise Wanteds with empty          -- RewriterSet] in GHC.Tc.Types.Constraint.          --          -- Unless we are sure that an error will be reported some other way@@ -525,7 +512,7 @@                = tidy_items1           -- First, deal with any out-of-scope errors:-       ; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs+       ; let (out_of_scope, other_holes, not_conc_errs, mult_co_errs) = partition_errors tidy_errs                -- don't suppress out-of-scope errors              ctxt_for_scope_errs = ctxt { cec_suppress = False }        ; (_, no_out_of_scope) <- askNoErrs $@@ -542,16 +529,23 @@         ; reportNotConcreteErrs ctxt_for_insols not_conc_errs +       -- We only want to report multiplicity coercion errors for multiplicity+       -- constraints which are /solved/ with a non-reflexivity coercion. We+       -- over approximate here: we only report multiplicity coercion errors+       -- when /all/ constraints are solved.+       -- See wrinkle (DME1) in Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify.+       ; when (null simples) $ reportMultiplicityCoercionErrs ctxt_for_insols mult_co_errs+           -- See Note [Suppressing confusing errors]-       ; let (suppressed_items, items0) = partition suppress tidy_items+       ; let (suppressed_items, reportable_items) = partition suppressItem tidy_items        ; traceTc "reportWanteds suppressed:" (ppr suppressed_items)-       ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0+       ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 reportable_items           -- Now all the other constraints.  We suppress errors here if          -- any of the first batch failed, or if the enclosing context          -- says to suppress        ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }-       ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1+       ; (_, leftovers) <- tryReporters ctxt2 report2 items1        ; massertPpr (null leftovers)            (text "The following unsolved Wanted constraints \                  \have not been reported to the user:"@@ -562,41 +556,37 @@             -- wanted insoluble here; but do suppress inner insolubles             -- if there's a *given* insoluble here (= inaccessible code) -            -- Only now, if there are no errors, do we report suppressed ones-            -- See Note [Suppressing confusing errors]-            -- We don't need to update the context further because of the-            -- whenNoErrs guard-       ; whenNoErrs $-         do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items+         -- If there are no other errors to report, report suppressed errors.+         -- See Note [Suppressing confusing errors].  NB: with -fdefer-type-errors+         -- we might have reported warnings only from `reportable_items`, but we+         -- still want to suppress the `suppressed_items`.+       ; when (null reportable_items) $+         do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2)+                                                  suppressed_items+                 -- ctxt_for_insols: the suppressed errors can be Int~Bool, which+                 -- will have made the incoming `ctxt` be True; don't make that+                 -- suppress the Int~Bool error!             ; massertPpr (null more_leftovers) (ppr more_leftovers) } }  where     env       = cec_tidy ctxt     tidy_cts  = bagToList (mapBag (tidyCt env)   simples)     tidy_errs = bagToList (mapBag (tidyDelayedError env) errs) -    partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError])-    partition_errors = go [] [] []-      where-        go out_of_scope other_holes syn_eqs []-          = (out_of_scope, other_holes, syn_eqs)-        go es1 es2 es3 (err:errs)-          | (es1, es2, es3) <- go es1 es2 es3 errs-          = case err of-              DE_Hole hole-                | isOutOfScopeHole hole-                -> (hole : es1, es2, es3)-                | otherwise-                -> (es1, hole : es2, es3)-              DE_NotConcrete err-                -> (es1, es2, err : es3)--      -- See Note [Suppressing confusing errors]-    suppress :: ErrorItem -> Bool-    suppress item-      | Wanted <- ei_flavour item-      = is_ww_fundep_item item-      | otherwise-      = False+    partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError], [(TcCoercion, CtLoc)])+    partition_errors []+      = ([], [], [], [])+    partition_errors (err:errs)+      | (es1, es2, es3, es4) <- partition_errors errs+      = case err of+          DE_Hole hole+            | isOutOfScopeHole hole+            -> (hole : es1, es2, es3, es4)+            | otherwise+            -> (es1, hole : es2, es3, es4)+          DE_NotConcrete err+            -> (es1, es2, err : es3, es4)+          DE_Multiplicity mult_co loc+            -> (es1, es2, es3, (mult_co, loc):es4)      -- report1: ones that should *not* be suppressed by     --          an insoluble somewhere else in the tree@@ -604,34 +594,53 @@     -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise     -- we might suppress its error message, and proceed on past     -- type checking to get a Lint error later-    report1 = [ ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)-                 -- (Handles TypeError and Unsatisfiable)+    report1 = [ -- We put implicit lifting errors first, because are solid errors+                -- See "Implicit lifting" in GHC.Tc.Gen.Splice+                -- Note [Lifecycle of an untyped splice, and PendingRnSplice]+                ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) +              -- Next, solid equality errors               , given_eq_spec               , ("insoluble2",      utterly_wrong,  True, mkGroupReporter mkEqErr)               , ("skolem eq1",      very_wrong,     True, mkSkolReporter)               , ("FixedRuntimeRep", is_FRR,         True, mkGroupReporter mkFRRErr)               , ("skolem eq2",      skolem_eq,      True, mkSkolReporter)++              -- Next, custom type errors+              -- See Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint+              --+              -- Put custom type errors /after/ solid equality errors.  In #26255 we+              -- had a custom error (T <= F alpha) which was suppressing a far more+              -- informative (K Int ~ [K alpha]). That mismatch between K and [] is+              -- definitely wrong; and if it was fixed we'd know alpha:=Int, and hence+              -- perhaps be able to solve T <= F alpha, by reducing F Int.+              --+              -- But put custom type errors /before/ "non-tv eq", because if we have+              --     () ~ TypeError blah+              -- we want to report it as a custom error, /not/ as a mis-match+              -- between TypeError and ()!  Also see the Assert example+              -- in Note [Custom type errors in constraints]+              , ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)+                 -- (Handles TypeError and Unsatisfiable)++              -- "non-tv-eq": equalities (ty1 ~ ty2) where ty1 is not a tyvar               , ("non-tv eq",       non_tv_eq,      True, mkSkolReporter)                    -- The only remaining equalities are alpha ~ ty,                   -- where alpha is untouchable; and representational equalities                   -- Prefer homogeneous equalities over hetero, because the                   -- former might be holding up the latter.-                  -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality+                  -- See Note [Equalities with heterogeneous kinds] in GHC.Tc.Solver.Equality               , ("Homo eqs",      is_homo_equality,  True,  mkGroupReporter mkEqErr)               , ("Other eqs",     is_equality,       True,  mkGroupReporter mkEqErr)+               ]      -- report2: we suppress these if there are insolubles elsewhere in the tree     report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)               , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)-              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]--    -- report3: suppressed errors should be reported as categorized by either report1-    -- or report2. Keep this in sync with the suppress function above-    report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr)-              ]+              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr)+              , ("Quantified",      is_qc,           False, mkGroupReporter mkQCErr) ]      -- rigid_nom_eq, rigid_nom_tv_eq,     is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool@@ -668,6 +677,11 @@     -- See also Note [Implementation of Unsatisfiable constraints], point (F).     is_user_type_error item _ = containsUserTypeError (errorItemPred item) +    is_implicit_lifting item _ =+      case (errorItemOrigin item) of+        ImplicitLiftOrigin {} -> True+        _ -> False+     is_homo_equality _ (EqPred _ ty1 ty2)       = typeKind ty1 `tcEqType` typeKind ty2     is_homo_equality _ _@@ -685,9 +699,8 @@     is_irred _ (IrredPred {}) = True     is_irred _ _              = False -     -- See situation (1) of Note [Suppressing confusing errors]-    is_ww_fundep item _ = is_ww_fundep_item item-    is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin+    is_qc _ (ForAllPred {}) = True+    is_qc _ _               = False      given_eq_spec  -- See Note [Given errors]       | has_gadt_match_here@@ -714,6 +727,16 @@       = has_gadt_match implics  ---------------+suppressItem :: ErrorItem -> Bool+ -- See Note [Suppressing confusing errors]+suppressItem item+  | Wanted <- ei_flavour item+  , let orig = errorItemOrigin item+  = isWantedSuperclassOrigin orig       -- See (SCE1)+    || isWantedWantedFunDepOrigin orig  -- See (SCE2)+  | otherwise+  = False+ isSkolemTy :: TcLevel -> Type -> Bool -- The type is a skolem tyvar isSkolemTy tc_lvl ty@@ -736,9 +759,25 @@ Certain errors we might encounter are potentially confusing to users. If there are any other errors to report, at all, we want to suppress these. -Which errors (only 1 case right now):+Which errors are suppressed? -1) Errors which arise from the interaction of two Wanted fun-dep constraints.+(SCE1) Superclasses of Wanteds.  These are generated only in case they trigger functional+   dependencies.  If such a constraint is unsolved, then its "parent" constraint must+   also be unsolved, and is much more informative to the user.  Example (#26255):+        class (MinVersion <= F era) => Era era where { ... }+        f :: forall era. EraFamily era -> IO ()+        f = ..blah...   -- [W] Era era+   Here we have simply omitted "Era era =>" from f's type.  But we'll end up with+   /two/ Wanted constraints:+        [W] d1 :  Era era+        [W] d2 : MinVersion <= F era  -- Superclass of d1+   We definitely want to report d1 and not d2!  Happily it's easy to filter out those+   superclass-Wanteds, becuase their Origin betrays them.++   See test T18851 for an example of how it is (just, barely) possible for the /only/+   errors to be superclass-of-Wanted constraints.++(SCE2) Errors which arise from the interaction of two Wanted fun-dep constraints.    Example:       class C a b | a -> b where@@ -781,7 +820,7 @@  Currently, the constraints to ignore are: -1) Constraints generated in order to unify associated type instance parameters+(CIG1) Constraints generated in order to unify associated type instance parameters    with class parameters. Here are two illustrative examples:       class C (a :: k) where@@ -809,6 +848,9 @@     If there is any trouble, checkValidFamInst bleats, aborting compilation. +(Note: Aug 25: this seems a rather tricky corner;+               c.f. Note [Suppressing confusing errors])+ Note [Implementation of Unsatisfiable constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Unsatisfiable constraint was introduced in GHC proposal #433 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst).@@ -954,7 +996,7 @@ -- Suppress duplicates with either the same LHS, or same location -- Pre-condition: all items are equalities mkSkolReporter ctxt items-  = mapM_ (reportGroup mkEqErr ctxt) (group (toList items))+  = mapM_ (reportGroup (mkEqErr ctxt) ctxt) (group (toList items))   where      group [] = []      group (item:items) = (item :| yeses) : group noes@@ -1025,7 +1067,7 @@ reportNotConcreteErrs :: SolverReportErrCtxt -> [NotConcreteError] -> TcM () reportNotConcreteErrs _ [] = return () reportNotConcreteErrs ctxt errs@(err0:_)-  = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) []+  = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) [] []        ; reportDiagnostic msg }    where@@ -1044,13 +1086,25 @@           | frr_errs <- go frr_errs errs           = case err of               NCE_FRR-                { nce_frr_origin = frr_orig-                , nce_reasons = _not_conc } ->+                { nce_frr_origin = frr_orig } ->                 FRR_Info                   { frr_info_origin       = frr_orig-                  , frr_info_not_concrete = Nothing }+                  , frr_info_not_concrete = Nothing+                  , frr_info_other_origin = Nothing }                 : frr_errs +reportMultiplicityCoercionErrs :: SolverReportErrCtxt -> [(TcCoercion, CtLoc)] -> TcM ()+reportMultiplicityCoercionErrs ctxt errs = mapM_ reportOne errs+  where+    reportOne :: (TcCoercion, CtLoc) -> TcM ()+    reportOne (_co, loc)+      = do { msg <- mkErrorReport (ctLocEnv loc) diag (Just ctxt) [] []+           ; reportDiagnostic msg }++    diag = TcRnSolverReport+             (SolverReportWithCtxt ctxt MultiplicityCoercionsNotSupported)+             ErrorWithoutFlag+ {- Note [Skip type holes rapidly] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have module with a /lot/ of partial type signatures, and we@@ -1068,7 +1122,7 @@ mkUserTypeErrorReporter ctxt   = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item                         ; maybeReportError ctxt (item :| []) err-                        ; addDeferredBinding ctxt err item }+                        ; addSolverDeferredBinding err item }  mkUserTypeError :: ErrorItem -> TcSolverReportMsg mkUserTypeError item@@ -1081,21 +1135,41 @@   where     pty = errorItemPred item +mkImplicitLiftingReporter :: Reporter+mkImplicitLiftingReporter ctxt+  = mapM_ $ \item -> do { let err = mkImplicitLiftingError item+                        ; msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item)) err (Just ctxt) [] []+                        ; reportDiagnostic msg+                        ; addDeferredBinding ctxt [] [] err item+                        }++  where+    mkImplicitLiftingError :: ErrorItem -> TcRnMessage+    mkImplicitLiftingError item =+      case errorItemOrigin item of+        ImplicitLiftOrigin (HsImplicitLiftSplice bound used gre name) ->+          TcRnBadlyLevelled (LevelCheckSplice (getName name) gre) bound used (Just item) (cec_defer_type_errors ctxt)+        _ -> pprPanic "mkImplicitLiftingError" (ppr item)+ mkGivenErrorReporter :: Reporter -- See Note [Given errors] mkGivenErrorReporter ctxt (item:|_)   = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item-       ; let (implic:_) = cec_encl ctxt-                 -- Always non-empty when mkGivenErrorReporter is called+       ; let implic =+               case cec_encl ctxt of+                -- cec_encl is always non-empty when mkGivenErrorReporter is called+                 outer_implic:_ -> outer_implic+                 _ -> pprPanic "mkGivenErrorReporter" (ppr item)+              loc'  = setCtLocEnv (ei_loc item) (ic_env implic)              item' = item { ei_loc = loc' }                    -- For given constraints we overwrite the env (and hence src-loc)                    -- with one from the immediately-enclosing implication.                    -- See Note [Inaccessible code]+        ; eq_err_msg <- mkEqErr_help ctxt item' ty1 ty2-       ; let supplementary = [ SupplementaryBindings relevant_binds ]-             msg = TcRnInaccessibleCode implic (SolverReportWithCtxt ctxt eq_err_msg)-       ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary+       ; let msg = TcRnInaccessibleCode implic (SolverReportWithCtxt ctxt eq_err_msg)+       ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) [SupplementaryBindings relevant_binds] []        ; reportDiagnostic msg }   where     (ty1, ty2)   = getEqPredTys (errorItemPred item)@@ -1148,7 +1222,7 @@ -- Group together errors from same location, -- and report only the first (to avoid a cascade) mkGroupReporter mk_err ctxt items-  = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc (toList items))+  = mapM_ (reportGroup (mk_err ctxt) ctxt) (equivClasses cmp_loc (toList items))  eq_lhs_type :: ErrorItem -> ErrorItem -> Bool eq_lhs_type item1 item2@@ -1164,9 +1238,9 @@              -- Reduce duplication by reporting only one error from each              -- /starting/ location even if the end location differs -reportGroup :: (SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport) -> Reporter+reportGroup :: (NonEmpty ErrorItem -> TcM SolverReport) -> Reporter reportGroup mk_err ctxt items-  = do { err <- mk_err ctxt items+  = do { err <- mk_err items        ; traceTc "About to maybeReportErr" $          vcat [ text "Constraint:"             <+> ppr items               , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)@@ -1174,7 +1248,7 @@        ; maybeReportError ctxt items err            -- But see Note [Always warn with -fdefer-type-errors]        ; traceTc "reportGroup" (ppr items)-       ; mapM_ (addDeferredBinding ctxt err) items }+       ; mapM_ (addSolverDeferredBinding err) items }            -- Add deferred bindings for all            -- Redundant if we are going to abort compilation,            -- but that's hard to know for sure, and if we don't@@ -1192,7 +1266,8 @@                  -> NonEmpty ErrorItem     -- items covered by the Report                  -> SolverReport -> TcM () maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = important-                                                     , sr_supplementary = supp })+                                                     , sr_supplementary = supp+                                                     , sr_hints         = hints })   = unless (cec_suppress ctxt  -- Some worse error has occurred, so suppress this diagnostic          || all ei_suppress items) $                            -- if they're all to be suppressed, report nothing@@ -1203,16 +1278,26 @@                   | otherwise                                         = cec_defer_type_errors ctxt                   -- See Note [No deferring for multiplicity errors]            diag = TcRnSolverReport important reason-       msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp+       msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp hints        reportDiagnostic msg -addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM ()+addSolverDeferredBinding :: SolverReport -> ErrorItem -> TcM ()+addSolverDeferredBinding err item =+  let ctxt = reportContext . sr_important_msg $ err+      supp = sr_supplementary err+      hints = sr_hints err+      important = sr_important_msg err+  in addDeferredBinding ctxt supp hints (TcRnSolverReport important ErrorWithoutFlag) item+++addDeferredBinding :: SolverReportErrCtxt -> [SupplementaryInfo] -> [GhcHint] -> TcRnMessage -> ErrorItem -> TcM () -- See Note [Deferring coercion errors to runtime]-addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty-                                , ei_loc = loc })-     -- if evdest is Just, then the constraint was from a wanted+addDeferredBinding ctxt supp hints msg (EI { ei_evdest = Just dest+                                           , ei_pred = item_ty+                                           , ei_loc = loc })+  -- if evdest is Just, then the constraint was from a wanted   | deferringAnyBindings ctxt-  = do { err_tm <- mkErrorTerm ctxt loc item_ty err+  = do { err_tm <- mkErrorTerm loc item_ty ctxt msg supp hints        ; let ev_binds_var = cec_binds ctxt         ; case dest of@@ -1223,14 +1308,26 @@                      let co_var = coHoleCoVar hole                    ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvNonCanonical err_tm                    ; fillCoercionHole hole (mkCoVarCo co_var) } }-addDeferredBinding _ _ _ = return ()    -- Do not set any evidence for Given+addDeferredBinding _ _ _ _ _ = return ()    -- Do not set any evidence for Given -mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type  -- of the error term-            -> SolverReport -> TcM EvTerm-mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msg = important, sr_supplementary = supp })+mkSolverErrorTerm :: CtLoc -> Type  -- of the error term+                  -> SolverReport -> TcM EvTerm+mkSolverErrorTerm ct_loc ty err+  = mkErrorTerm ct_loc ty (reportContext . sr_important_msg $ err)+                          (TcRnSolverReport (sr_important_msg err) ErrorWithoutFlag)+                          (sr_supplementary err)+                          (sr_hints err)++mkErrorTerm :: CtLoc -> Type  -- of the error term+            -> SolverReportErrCtxt -> TcRnMessage+            -> [SupplementaryInfo] -> [GhcHint] -> TcM EvTerm+mkErrorTerm ct_loc ty ctxt msg supp hints   = do { msg <- mkErrorReport                   (ctLocEnv ct_loc)-                  (TcRnSolverReport important ErrorWithoutFlag) (Just ctxt) supp+                  msg+                  (Just $ ctxt)+                  supp+                  hints          -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"        ; dflags <- getDynFlags        ; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg@@ -1286,74 +1383,22 @@                   -- ^ The context to add, after the main diagnostic                   -- but before the supplementary information.                   -- Nothing <=> don't add any context.-              -> [SolverReportSupplementary]+              -> [SupplementaryInfo]                   -- ^ Supplementary information, to be added at the end of the message.+              -> [GhcHint]+                  -- ^ Suggested fixes               -> TcM (MsgEnvelope TcRnMessage)-mkErrorReport tcl_env msg mb_ctxt supplementary-  = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt+mkErrorReport tcl_env msg mb_ctxt supp hints+  = do { mb_context <- traverse (\ ctxt -> mkErrCtxt (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt        ; unit_state <- hsc_units <$> getTopEnv        ; hfdc <- getHoleFitDispConfig        ; let-           err_info =-             ErrInfo-               (fromMaybe empty mb_context)-               (vcat $ map (pprSolverReportSupplementary hfdc) supplementary)-       ; let detailed_msg = mkDetailedMessage err_info msg+           err_info = ErrInfo (fromMaybe [] mb_context) (Just (hfdc, supp)) hints+           detailed_msg = mkDetailedMessage err_info msg        ; mkTcRnMessage            (RealSrcSpan (ctl_loc tcl_env) Strict.Nothing)            (TcRnMessageWithInfo unit_state $ detailed_msg) } ----- | Pretty-print supplementary information, to add to an error report.-pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc--- This function should be in "GHC.Tc.Errors.Ppr",--- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.-pprSolverReportSupplementary hfdc = \case-  SupplementaryBindings binds -> pprRelevantBindings binds-  SupplementaryHoleFits fits  -> pprValidHoleFits hfdc fits-  SupplementaryCts      cts   -> pprConstraintsInclude cts---- | Display a collection of valid hole fits.-pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc--- This function should be in "GHC.Tc.Errors.Ppr",--- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.-pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs))-  = fits_msg $$ refs_msg--  where-    fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc-    fits_msg = ppUnless (null fits) $-                    hang (text "Valid hole fits include") 2 $-                    vcat (map (pprHoleFit hfdc) fits)-                      $$ ppWhen  discarded_fits fits_discard_msg-    refs_msg = ppUnless (null refs) $-                  hang (text "Valid refinement hole fits include") 2 $-                  vcat (map (pprHoleFit hfdc) refs)-                    $$ ppWhen discarded_refs refs_discard_msg-    fits_discard_msg =-      text "(Some hole fits suppressed;" <+>-      text "use -fmax-valid-hole-fits=N" <+>-      text "or -fno-max-valid-hole-fits)"-    refs_discard_msg =-      text "(Some refinement hole fits suppressed;" <+>-      text "use -fmax-refinement-hole-fits=N" <+>-      text "or -fno-max-refinement-hole-fits)"---- | Add a "Constraints include..." message.------ See Note [Constraints include ...]-pprConstraintsInclude :: [(PredType, RealSrcSpan)] -> SDoc--- This function should be in "GHC.Tc.Errors.Ppr",--- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.-pprConstraintsInclude cts-  = ppUnless (null cts) $-     hang (text "Constraints include")-        2 (vcat $ map pprConstraint cts)-  where-    pprConstraint (constraint, loc) =-      ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))- {- Note [Always warn with -fdefer-type-errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When -fdefer-type-errors is on we warn about *all* type errors, even@@ -1370,22 +1415,22 @@  Note [No deferring for multiplicity errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As explained in Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify,+As explained in Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify, linear types do not support casts and any nontrivial coercion will raise-an error during desugaring.+an error at the end of typechecking (a delayed error).  This means that even if we defer a multiplicity mismatch during typechecking,-the desugarer will refuse to compile anyway. Worse: the error raised-by the desugarer would shadow the type mismatch warnings (#20083).-As a solution, we refuse to defer submultiplicity constraints. Test: T20083.+the desugarer will refuse to compile anyway. Worse: the delayed error would+shadow the type mismatch warnings (#20083).  As a solution, we refuse to defer+submultiplicity constraints. Test: T20083.  To determine whether a constraint arose from a submultiplicity check, we look at the CtOrigin. All calls to tcSubMult use origins which are not used outside of linear types. -In the future, we should compile 'WpMultCoercion' to a runtime error with--fdefer-type-errors, but the current implementation does not always-place the wrapper in the right place and the resulting program can fail Lint.+In the future, we should compile unsolved multiplicity constraints to a runtime error with+-fdefer-type-errors, but there's currently no good way to insert this type error+in the desugared  program. Especially in a way that would pass the linter. This plan is tracked in #20083.  Note [Deferred errors for coercion holes]@@ -1450,23 +1495,28 @@ ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)-mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc })+mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_sort = sort, hole_occ = occ, hole_loc = ct_loc })   | isOutOfScopeHole hole   = do { (imp_errs, hints)-           <- unknownNameSuggestions (ctl_rdr lcl_env) WL_Anything occ+           <- unknownNameSuggestions (ctl_rdr lcl_env) what_look occ        ; let              err    = SolverReportWithCtxt ctxt-                    $ ReportHoleError hole-                    $ OutOfScopeHole imp_errs hints-             report = SolverReport err []+                    $ ReportHoleError hole OutOfScopeHole+             supp   = [ SupplementaryImportErrors imps | imps <- maybeToList (NE.nonEmpty imp_errs) ] -       ; maybeAddDeferredBindings ctxt hole report-       ; mkErrorReport lcl_env (TcRnSolverReport err (cec_out_of_scope_holes ctxt))-           Nothing []-          -- Pass the value 'Nothing' for the context, as it's generally not helpful-          -- to include the context here.+       ; maybeAddDeferredBindings hole $ SolverReport err supp hints+       ; mkErrorReport lcl_env+           ( TcRnSolverReport err (cec_out_of_scope_holes ctxt)+           )+           Nothing supp hints+             -- Pass the value 'Nothing' for the context, as it's generally not helpful+             -- to include the context here.        }   where+    what_look = case sort of+      ExprHole {} -> WL_Term+      TypeHole {} -> WL_Type+      ConstraintHole {} -> WL_Type     lcl_env = ctLocEnv ct_loc   -- general case: not an out-of-scope error@@ -1495,13 +1545,13 @@              err  = SolverReportWithCtxt ctxt                   $ ReportHoleError hole                   $ HoleError sort other_tvs grouped_skvs-             supp = [ SupplementaryBindings rel_binds-                    , SupplementaryCts      relevant_cts-                    , SupplementaryHoleFits hole_fits ]--       ; maybeAddDeferredBindings ctxt hole (SolverReport err supp)+             supp =    [ SupplementaryBindings rel_binds ]+                    ++ [ SupplementaryCts      cts | cts <- maybeToList (NE.nonEmpty relevant_cts) ]+                    ++ [ SupplementaryHoleFits hole_fits ] -       ; mkErrorReport lcl_env (TcRnSolverReport err reason) (Just ctxt) supp+       ; maybeAddDeferredBindings hole (SolverReport err supp noHints)+       ; let msg = TcRnSolverReport err reason+       ; mkErrorReport lcl_env msg (Just ctxt) supp noHints        }    where@@ -1539,22 +1589,23 @@  -- | Adds deferred bindings (as errors). -- See Note [Adding deferred bindings].-maybeAddDeferredBindings :: SolverReportErrCtxt-                         -> Hole+maybeAddDeferredBindings :: Hole                          -> SolverReport                          -> TcM ()-maybeAddDeferredBindings ctxt hole report = do+maybeAddDeferredBindings hole report = do   case hole_sort hole of     ExprHole (HER ref ref_ty _) -> do       -- Only add bindings for holes in expressions       -- not for holes in partial type signatures       -- cf. addDeferredBinding       when (deferringAnyBindings ctxt) $ do-        err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report+        err_tm <- mkSolverErrorTerm (hole_loc hole) ref_ty report           -- NB: ref_ty, not hole_ty. hole_ty might be rewritten.-          -- See Note [Holes] in GHC.Tc.Types.Constraint+          -- See Note [Holes in expressions] in GHC.Hs.Expr         writeMutVar ref err_tm     _ -> pure ()+  where+    ctxt = reportContext $ sr_important_msg $ report  -- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module -- imports@@ -1575,10 +1626,11 @@     mk_wanted :: ErrorItem -> Maybe CtEvidence     mk_wanted (EI { ei_pred = pred, ei_evdest = m_dest, ei_loc = loc })       | Just dest <- m_dest-      = Just (CtWanted { ctev_pred      = pred-                       , ctev_dest      = dest-                       , ctev_loc       = loc-                       , ctev_rewriters = emptyRewriterSet })+      = Just $ CtWanted $+          WantedCt { ctev_pred      = pred+                   , ctev_dest      = dest+                   , ctev_loc       = loc+                   , ctev_rewriters = emptyRewriterSet }       | otherwise       = Nothing   -- The ErrorItem was a Given @@ -1616,7 +1668,7 @@             -- Zonk/tidy to show useful variable names.           nubOrdBy (nonDetCmpType `on` (frr_type . frr_info_origin)) $             -- Remove duplicates: only one representation-polymorphism error per type.-          map (expectJust "mkFRRErr" . fixedRuntimeRepOrigin_maybe) $+          map (expectJust . fixedRuntimeRepOrigin_maybe) $           toList items        ; return $ important ctxt $ FixedRuntimeRepError frr_infos } @@ -1624,21 +1676,25 @@ fixedRuntimeRepOrigin_maybe :: HasDebugCallStack => ErrorItem -> Maybe FixedRuntimeRepErrorInfo fixedRuntimeRepOrigin_maybe item   -- An error that arose directly from a representation-polymorphism check.-  | FRROrigin frr_orig <- errorItemOrigin item+  | FRROrigin frr_orig <- orig   = Just $ FRR_Info { frr_info_origin = frr_orig-                    , frr_info_not_concrete = Nothing }+                    , frr_info_not_concrete = Nothing+                    , frr_info_other_origin = Nothing+                    }   -- A nominal equality involving a concrete type variable,   -- such as @alpha[conc] ~# rr[sk]@ or @beta[conc] ~# RR@ for a   -- type family application @RR@.   | EqPred NomEq ty1 ty2 <- classifyPredType (errorItemPred item)   = if | Just (tv1, ConcreteFRR frr1) <- isConcreteTyVarTy_maybe ty1-       -> Just $ FRR_Info frr1 (Just (tv1, ty2))+       -> Just $ FRR_Info frr1 (Just (tv1, ty2)) (Just orig)        | Just (tv2, ConcreteFRR frr2) <- isConcreteTyVarTy_maybe ty2-       -> Just $ FRR_Info frr2 (Just (tv2, ty1))+       -> Just $ FRR_Info frr2 (Just (tv2, ty1)) (Just orig)        | otherwise        -> Nothing   | otherwise   = Nothing+  where+    orig = errorItemOrigin item  {- Note [Constraints include ...]@@ -1762,12 +1818,12 @@              -> ErrorItem              -> TcType -> TcType -> TcM TcSolverReportMsg mkEqErr_help ctxt item ty1 ty2-  | Just casted_tv1 <- getCastedTyVar_maybe ty1-  = mkTyVarEqErr ctxt item casted_tv1 ty2+  | Just (tv1, _co) <- getCastedTyVar_maybe ty1+  = mkTyVarEqErr ctxt item tv1 ty2    -- ToDo: explain..  Cf T2627b   Dual (Dual a) ~ a-  | Just casted_tv2 <- getCastedTyVar_maybe ty2-  = mkTyVarEqErr ctxt item casted_tv2 ty1+  | Just (tv2, _co) <- getCastedTyVar_maybe ty2+  = mkTyVarEqErr ctxt item tv2 ty1    | otherwise   = reportEqErr ctxt item ty1 ty2@@ -1800,15 +1856,15 @@     return $ mkCoercibleExplanation rdr_env fam_envs ty1 ty2  mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem-             -> (TcTyVar, TcCoercionN) -> TcType -> TcM TcSolverReportMsg+             -> TcTyVar -> TcType -> TcM TcSolverReportMsg -- tv1 and ty2 are already tidied-mkTyVarEqErr ctxt item casted_tv1 ty2-  = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr casted_tv1 $$ ppr ty2)-       ; mkTyVarEqErr' ctxt item casted_tv1 ty2 }+mkTyVarEqErr ctxt item tv1 ty2+  = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr tv1 $$ ppr ty2)+       ; mkTyVarEqErr' ctxt item tv1 ty2 }  mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem-              -> (TcTyVar, TcCoercionN) -> TcType -> TcM TcSolverReportMsg-mkTyVarEqErr' ctxt item (tv1, co1) ty2+              -> TcTyVar -> TcType -> TcM TcSolverReportMsg+mkTyVarEqErr' ctxt item tv1 ty2    -- Is this a representation-polymorphism error, e.g.   -- alpha[conc] ~# rr[sk] ? If so, handle that first.@@ -1838,12 +1894,6 @@         -- to be helpful since this is just an unimplemented feature.     return main_msg -  -- Incompatible kinds-  -- This is wrinkle (EIK2) in Note [Equalities with incompatible kinds]-  -- in GHC.Tc.Solver.Equality-  | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2-  = return $ mkBlockedEqErr item-   | isSkolemTyVar tv1  -- ty2 won't be a meta-tyvar; we would have                        -- swapped in Solver.Equality.canEqTyVarHomo     || isTyVarTyVar tv1 && not (isTyVarTy ty2)@@ -1919,8 +1969,10 @@   -- See Note [Error messages for untouchables]   | (implic:_) <- cec_encl ctxt   -- Get the innermost context   , Implic { ic_tclvl = lvl } <- implic-  = assertPpr (not (isTouchableMetaTyVar lvl tv1))+  = assertPpr (not (isTouchableMetaTyVar lvl tv1) || hasCoercionHole ty2)               (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables]+         -- We can still get touchable meta-tyvars on the LHS if there is an+         -- unsolved coercion hole, e.g.   (alpha::Type) ~ Int# |> co_hole     tv_extra <- extraTyVarEqInfo (tv1, Just implic) ty2     let tv_extra' = tv_extra { thisTyVarIsUntouchable = Just implic }         msg = Mismatch@@ -1956,7 +2008,8 @@       = Nothing     frr_reason (ConcreteFRR frr_orig) conc_tv not_conc       = FRR_Info { frr_info_origin = frr_orig-                 , frr_info_not_concrete = Just (conc_tv, not_conc) }+                 , frr_info_not_concrete = Just (conc_tv, not_conc)+                 , frr_info_other_origin = Just (errorItemOrigin item) }      ty1 = mkTyVarTy tv1 @@ -2027,14 +2080,6 @@               -- Keep only UserGivens that have some equalities.               -- See Note [Suppress redundant givens during error reporting] --- These are for the "blocked" equalities, as described in GHC.Tc.Solver.Equality--- Note [Equalities with incompatible kinds], wrinkle (EIK2). There should--- always be another unsolved wanted around, which will ordinarily suppress--- this message. But this can still be printed out with -fdefer-type-errors--- (sigh), so we must produce a message.-mkBlockedEqErr :: ErrorItem -> TcSolverReportMsg-mkBlockedEqErr item = BlockedEquality item- {- Note [Suppress redundant givens during error reporting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2209,6 +2254,15 @@ ************************************************************************ -} +mkQCErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport+mkQCErr ctxt items+  | item1 :| _ <- tryFilter (not . ei_suppress) items+    -- Ignore multiple qc-errors on the same line+  = do { let msg = mkPlainMismatchMsg $+                   CouldNotDeduce (getUserGivens ctxt) (item1 :| []) Nothing+       ; return $ important ctxt msg }++ mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport mkDictErr ctxt orig_items   = do { inst_envs <- tcGetInstEnvs@@ -2221,8 +2275,16 @@        -- But we report only one of them (hence 'head') because they all        -- have the same source-location origin, to try avoid a cascade        -- of error from one location-       ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items))-       ; return $ important ctxt err }+       ; ( err, (imp_errs, hints) ) <-+           mk_dict_err ctxt (head (no_inst_items ++ overlap_items))+       ; return $+           SolverReport+             { sr_important_msg = SolverReportWithCtxt ctxt err+             , sr_supplementary = [ SupplementaryImportErrors imps+                                  | imps <- maybeToList (NE.nonEmpty imp_errs) ]+             , sr_hints = hints+             }+        }   where     items = tryFilter (not . ei_suppress) orig_items @@ -2256,25 +2318,31 @@ --     matching and unifying instances, and say "The choice depends on the instantion of ..., --     and the result of evaluating ...". mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)-            -> TcM TcSolverReportMsg-mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of+            -> TcM ( TcSolverReportMsg, ([ImportError], [GhcHint]) )+mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped))+  = case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of   (Nothing, _)  -> do -- No matches but perhaps several unifiers     { (_, rel_binds, item) <- relevantBindings True ctxt item     ; candidate_insts <- get_candidate_instances     ; (imp_errs, field_suggestions) <- record_field_suggestions item-    ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) }+    ; return (CannotResolveInstance item unifiers candidate_insts rel_binds, (imp_errs, field_suggestions)) }    -- Some matches => overlap errors   (Just matchesNE, Nothing) -> return $-    OverlappingInstances item (NE.map fst matchesNE) (getCoherentUnifiers unifiers)+    ( OverlappingInstances item (NE.map fst matchesNE) unifiers, ([], []))    (Just (match :| []), Just unsafe_overlappedNE) -> return $-    UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE)-  (Just matches@(_ :| _), Just overlaps) -> pprPanic "mk_dict_err: multiple matches with overlap" $ vcat [ text "matches:" <+> ppr matches, text "overlaps:" <+> ppr overlaps ]+    ( UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE), ([], []))+  (Just matches@(_ :| _), Just overlaps) ->+    pprPanic "mk_dict_err: multiple matches with overlap" $+      vcat [ text "matches:" <+> ppr matches+           , text "overlaps:" <+> ppr overlaps+           ]   where-    orig          = errorItemOrigin item-    pred          = errorItemPred item-    (clas, tys)   = getClassPredTys pred+    orig        = errorItemOrigin item+    pred        = errorItemPred item+    (clas, tys) = getClassPredTys pred+    unifiers    = getCoherentUnifiers pot_unifiers      get_candidate_instances :: TcM [ClsInst]     -- See Note [Report candidate instances]@@ -2315,7 +2383,7 @@     report_no_fieldnames item        | Just (EvVarDest evvar) <- ei_evdest item        -- we can assume that here we have a `HasField @Symbol x r a` instance-       -- because of HasFieldOrigin in record_field+       -- because of GetFieldOrigin in record_field        , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar)        , Just (r_tycon, _) <- tcSplitTyConApp_maybe r        , Just x_name <- isStrLitTy x@@ -2330,13 +2398,8 @@       isNothing (lookupLocalRdrOcc lcl_env occ_name)      record_field = case orig of-      HasFieldOrigin name -> Just (mkVarOccFS name)+      GetFieldOrigin name -> Just (mkVarOccFS name)       _                   -> Nothing--    cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings-                       -> [ImportError] -> [GhcHint] -> TcSolverReportMsg-    cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions-      = CannotResolveInstance item (getCoherentUnifiers unifiers) candidate_insts imp_errs field_suggestions binds  {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Errors/Hole.hs view
@@ -11,7 +11,6 @@    , isFlexiTyVar    , tcFilterHoleFits    , getLocalBindings-   , pprHoleFit    , addHoleFitDocs    , getHoleFitSortingAlg    , getHoleFitDispConfig@@ -42,14 +41,15 @@ import GHC.Tc.Types.CtLoc import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.TcType-import GHC.Core.Type import GHC.Core.TyCon( TyCon, isGenerativeTyCon ) import GHC.Core.TyCo.Rep( Type(..) ) import GHC.Core.DataCon import GHC.Core.Predicate( Pred(..), classifyPredType, eqRelRole )+import GHC.Types.Basic import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Builtin.Names ( gHC_INTERNAL_ERR, gHC_INTERNAL_UNSAFE_COERCE )+import GHC.Builtin.Types ( tupleDataConName, unboxedSumDataConName ) import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Var.Env@@ -57,7 +57,6 @@ import GHC.Data.Bag import GHC.Core.ConLike ( ConLike(..) ) import GHC.Utils.Misc-import GHC.Utils.Panic import GHC.Tc.Utils.Env (tcLookup) import GHC.Utils.Outputable import GHC.Driver.DynFlags@@ -89,7 +88,11 @@ import GHC.Data.FastString (NonDetFastString(..)) import GHC.Types.Unique.Map +import GHC.Data.EnumSet (EnumSet)+import qualified GHC.Data.EnumSet as EnumSet+import qualified GHC.LanguageExtensions as LangExt + {- Note [Valid hole fits include ...] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -471,17 +474,17 @@        else return fits }   where    msg = text "GHC.Tc.Errors.Hole addHoleFitDocs"-   upd mb_local_docs mods_without_docs fit@(HoleFit {hfCand = cand}) =+   upd mb_local_docs mods_without_docs (TcHoleFit fit@(HoleFit {hfCand = cand})) =      let name = getName cand in      do { mb_docs <- if hfIsLcl fit                      then pure mb_local_docs                      else mi_docs <$> loadInterfaceForName msg name         ; case mb_docs of-            { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, fit)+            { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, TcHoleFit fit)             ; Just docs -> do                 { let doc = lookupUniqMap (docs_decls docs) name-                ; return $ (mods_without_docs, fit {hfDoc = map hsDocString <$> doc}) }}}-   upd _ mods_without_docs fit = pure (mods_without_docs, fit)+                ; return $ (mods_without_docs, TcHoleFit (fit {hfDoc = map hsDocString <$> doc})) }}}+   upd _ mods_without_docs fit@(RawHoleFit {}) = pure (mods_without_docs, fit)    nameOrigin name = case nameModule_maybe name of      Just m  -> Right m      Nothing ->@@ -498,63 +501,6 @@      ; warnPprTrace (not $ Set.null mods) "addHoleFitDocs" warning (pure ())      } --- For pretty printing hole fits, we display the name and type of the fit,--- with added '_' to represent any extra arguments in case of a non-zero--- refinement level.-pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc-pprHoleFit _ (RawHoleFit sd) = sd-pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =- hang display 2 provenance- where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap-         where pprArg b arg = case binderFlag b of-                                Specified -> text "@" <> pprParendType arg-                                  -- Do not print type application for inferred-                                  -- variables (#16456)-                                Inferred  -> empty-                                Required  -> pprPanic "pprHoleFit: bad Required"-                                                         (ppr b <+> ppr arg)-       tyAppVars = sep $ punctuate comma $-           zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+>-                                               text "~" <+> pprParendType t)-           vars hfWrap--       vars = unwrapTypeVars hfType-         where-           -- Attempts to get all the quantified type variables in a type,-           -- e.g.-           -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a)-           -- into [m, a]-           unwrapTypeVars :: Type -> [ForAllTyBinder]-           unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of-                               Just (_, _, _, unfunned) -> unwrapTypeVars unfunned-                               _ -> []-             where (vars, unforalled) = splitForAllForAllTyBinders t-       holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches-       holeDisp = if sMs then holeVs-                  else sep $ replicate (length hfMatches) $ text "_"-       occDisp = case hfCand of-                   GreHFCand gre   -> pprPrefixOcc (greName gre)-                   NameHFCand name -> pprPrefixOcc name-                   IdHFCand id_    -> pprPrefixOcc id_-       tyDisp = ppWhen sTy $ dcolon <+> ppr hfType-       has = not . null-       wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars))-                   $ text "with" <+> if sWrp || not sTy-                                     then occDisp <+> tyApp-                                     else tyAppVars-       docs = case hfDoc of-                Just d -> pprHsDocStrings d-                _ -> empty-       funcInfo = ppWhen (has hfMatches && sTy) $-                    text "where" <+> occDisp <+> tyDisp-       subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp-       display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)-       provenance = ppWhen sProv $ parens $-             case hfCand of-                 GreHFCand gre -> pprNameProvenance gre-                 NameHFCand name -> text "bound at" <+> ppr (getSrcLoc name)-                 IdHFCand id_ -> text "bound at" <+> ppr (getSrcLoc id_)- getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] getLocalBindings tidy_orig ct_loc  = do { (env1, _) <- liftZonkM $ zonkTidyOrigin tidy_orig (ctLocOrigin ct_loc)@@ -590,6 +536,7 @@      ; maxVSubs <- maxValidHoleFits <$> getDynFlags      ; sortingAlg <- getHoleFitSortingAlg      ; dflags <- getDynFlags+     ; let exts = extensionFlags dflags      ; hfPlugs <- tcg_hf_plugins <$> getGblEnv      ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs            refLevel = refLevelHoleFits dflags@@ -611,7 +558,7 @@            locals = removeBindingShadowing $                       map IdHFCand lclBinds ++ map GreHFCand lcl            globals = map GreHFCand gbl-           syntax = map NameHFCand builtIns+           syntax = map NameHFCand (builtIns exts)            -- If the hole is a rigid type-variable, then we only check the            -- locals, since only they can match the type (in a meaningful way).            only_locals = any isImmutableTyVar $ getTyVar_maybe hole_ty@@ -623,7 +570,9 @@         tcFilterHoleFits findVLimit hole (hole_ty, []) cands      ; (tidy_env, tidy_subs) <- liftZonkM $ zonkSubs tidy_env subs      ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs-     ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins+     ; let apply_plugin :: [HoleFit] -> ([HoleFit] -> TcM [HoleFit]) -> TcM [HoleFit]+           apply_plugin fits plug = plug fits+     ; plugin_handled_subs <- foldM apply_plugin (map TcHoleFit tidy_sorted_subs) fitPlugins      ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs            vDiscards = pVDisc || searchDiscards      ; subs_with_docs <- addHoleFitDocs limited_subs@@ -642,19 +591,21 @@             ; traceTc "ref_tys are" $ ppr ref_tys             ; let findRLimit = if sortingAlg > HFSNoSorting then Nothing                                                             else maxRSubs-            ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole)-                              cands) ref_tys-            ; (tidy_env, tidy_rsubs) <- liftZonkM $ zonkSubs tidy_env $ concatMap snd refDs-            ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs+            ; refDs :: [(Bool, [TcHoleFit])]+                 <- mapM (flip (tcFilterHoleFits findRLimit hole) cands) ref_tys+            ; (tidy_env, tidy_rsubs :: [TcHoleFit])+                 <- liftZonkM $ zonkSubs tidy_env $ concatMap snd refDs+            ; tidy_sorted_rsubs :: [TcHoleFit] <- sortFits sortingAlg tidy_rsubs             -- For refinement substitutions we want matches             -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t),             -- and others in that vein to appear last, since these are             -- unlikely to be the most relevant fits.             ; (tidy_env, tidy_hole_ty) <- liftZonkM $ zonkTidyTcType tidy_env hole_ty             ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap+                  exact, not_exact :: [TcHoleFit]                   (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs-            ; plugin_handled_rsubs <- foldM (flip ($))-                                        (not_exact ++ exact) fitPlugins+                  fits :: [HoleFit] = map TcHoleFit (not_exact ++ exact)+            ; plugin_handled_rsubs <- foldM apply_plugin fits fitPlugins             ; let (pRDisc, exact_last_rfits) =                     possiblyDiscard maxRSubs $ plugin_handled_rsubs                   rDiscards = pRDisc || any fst refDs@@ -669,9 +620,29 @@     hole_lvl = ctLocLevel ct_loc      -- BuiltInSyntax names like (:) and []-    builtIns :: [Name]-    builtIns = filter isBuiltInSyntax knownKeyNames+    builtIns :: EnumSet LangExt.Extension -> [Name]+    builtIns exts = filter isBuiltInSyntax (knownKeyNames ++ infFamNames)+      where+        -- Tuples and sums of are not included in knownKeyName as there are infinitely many of them.+        -- See Note [Infinite families of known-key names] in GHC.Builtin.Names.+        infFamNames =+             [tupleDataConName Boxed   n | n <- [0..max_tup]]+          ++ [tupleDataConName Unboxed n | unboxedTuples, n <- [0..max_tup]]+          ++ [unboxedSumDataConName k  n | unboxedSums, n <- [2..max_sum], k <- [1..n]] +        -- The upper limits on arity are small to avoid bloating the list with+        -- too many names, which would incur a performance cost.+        -- Users are unlikely to care about larger tuples/sums anyway.+        max_tup = 7+          -- Tuples up to (,,,,,,). Common limit, e.g. this is the highest tuple+          -- arity that has a Functor instance.+        max_sum = 7+          -- Sums up to (#||||||#). Results in 27 sum constructors because there+          -- are [1..n] data constructors at each arity.++        unboxedTuples = EnumSet.member LangExt.UnboxedTuples exts+        unboxedSums   = EnumSet.member LangExt.UnboxedSums exts+     -- We make a refinement type by adding a new type variable in front     -- of the type of t h hole, going from e.g. [Integer] -> Integer     -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier@@ -685,8 +656,8 @@             wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty      sortFits :: HoleFitSortingAlg    -- How we should sort the hole fits-             -> [HoleFit]     -- The subs to sort-             -> TcM [HoleFit]+             -> [TcHoleFit]     -- The subs to sort+             -> TcM [TcHoleFit]     sortFits HFSNoSorting subs = return subs     sortFits HFSBySize subs         = (++) <$> sortHoleFitsBySize (sort lclFits)@@ -731,14 +702,13 @@  -- We zonk the hole fits so that the output aligns with the rest -- of the typed hole error message output.-zonkSubs :: TidyEnv -> [HoleFit] -> ZonkM (TidyEnv, [HoleFit])+zonkSubs :: TidyEnv -> [TcHoleFit] -> ZonkM (TidyEnv, [TcHoleFit]) 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 -> ZonkM (TidyEnv, HoleFit)-        zonkSub env hf@RawHoleFit{} = return (env, hf)+        zonkSub :: TidyEnv -> TcHoleFit -> ZonkM (TidyEnv, TcHoleFit)         zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}             = do { (env, ty') <- zonkTidyTcType env ty                 ; (env, m')   <- zonkTidyTcTypes env m@@ -750,9 +720,9 @@ -- 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 :: [TcHoleFit] -> TcM [TcHoleFit] sortHoleFitsBySize = return . sortOn sizeOfFit-  where sizeOfFit :: HoleFit -> TypeSize+  where sizeOfFit :: TcHoleFit -> TypeSize         sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap  -- Based on a suggestion by phadej on #ghc, we can sort the found fits@@ -761,12 +731,12 @@ -- 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 :: [TcHoleFit] -> TcM [TcHoleFit] 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 :: [(TcHoleFit, [TcHoleFit])] -> [TcHoleFit] -> TcM [TcHoleFit]         go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar                          ; return $ uncurry (++) $ partition hfIsLcl topSorted }           where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)@@ -788,7 +758,7 @@                -- additional holes.                -> [HoleFitCandidate]                -- ^ The candidates to check whether fit.-               -> TcM (Bool, [HoleFit])+               -> TcM (Bool, [TcHoleFit])                -- ^ We return whether or not we stopped due to hitting the limit                -- and the fits we found. tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0@@ -803,12 +773,12 @@     -- Kickoff the checking of the elements.     -- We iterate over the elements, checking each one in turn for whether     -- it fits, and adding it to the results if it does.-    go :: [HoleFit]           -- What we've found so far.+    go :: [TcHoleFit]           -- What we've found so far.        -> VarSet              -- Ids we've already checked        -> Maybe Int           -- How many we're allowed to find, if limited        -> (TcType, [TcTyVar]) -- The type, and its refinement variables.        -> [HoleFitCandidate]  -- The elements we've yet to check.-       -> TcM (Bool, [HoleFit])+       -> TcM (Bool, [TcHoleFit])     go subs _ _ _ [] = return (False, reverse subs)     go subs _ (Just 0) _ _ = return (True, reverse subs)     go subs seen maxleft ty (el:elts) =
compiler/GHC/Tc/Errors/Hole.hs-boot view
@@ -4,41 +4,13 @@ -- + which calls 'GHC.Tc.Solver.simpl_top' module GHC.Tc.Errors.Hole where -import GHC.Types.Var ( Id ) import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) import GHC.Tc.Types  ( TcM ) import GHC.Tc.Types.Constraint ( CtEvidence, Hole, Implication )-import GHC.Tc.Types.CtLoc( CtLoc )-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, TcTyVar )-import GHC.Tc.Zonk.Monad ( ZonkM )-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] -> [CtEvidence] -> Hole                   -> TcM (TidyEnv, ValidHoleFits) -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 HoleFitSortingAlg--pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc-getHoleFitSortingAlg :: TcM HoleFitSortingAlg getHoleFitDispConfig :: TcM HoleFitDispConfig -zonkSubs :: TidyEnv -> [HoleFit] -> ZonkM (TidyEnv, [HoleFit])-sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit]-sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]
compiler/GHC/Tc/Gen/Annotation.hs view
@@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-}  -- | Typechecking annotations-module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where+module GHC.Tc.Gen.Annotation ( tcAnnotations ) where  import GHC.Prelude @@ -23,8 +23,6 @@  import GHC.Hs -import GHC.Utils.Outputable- import GHC.Types.Name import GHC.Types.Annotations import GHC.Types.SrcLoc@@ -54,7 +52,7 @@     let target = annProvenanceToTarget mod provenance      -- Run that annotation and construct the full Annotation data structure-    setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do+    setSrcSpanA loc $ addErrCtxt (AnnCtxt ann) $ do       -- See #10826 -- Annotations allow one to bypass Safe Haskell.       dflags <- getDynFlags       when (safeLanguageOn dflags) $ failWithTc TcRnAnnotationInSafeHaskell@@ -66,6 +64,3 @@ annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod -annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc-annCtxt ann-  = hang (text "In the annotation:") 2 (ppr ann)
compiler/GHC/Tc/Gen/App.hs view
@@ -16,7 +16,6 @@  module GHC.Tc.Gen.App        ( tcApp-       , tcInferSigma        , tcExprPrag ) where  import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )@@ -33,6 +32,7 @@ import GHC.Tc.Utils.Concrete  ( unifyConcrete, idConcreteTvs ) import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence+import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..) ) import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Tc.Utils.Concrete( hasFixedRuntimeRep_syntactic )@@ -166,26 +166,6 @@  {- ********************************************************************* *                                                                      *-              tcInferSigma-*                                                                      *-********************************************************************* -}--tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType--- Used only to implement :type; see GHC.Tc.Module.tcRnExpr--- True  <=> instantiate -- return a rho-type--- False <=> don't instantiate -- return a sigma-type-tcInferSigma inst (L loc rn_expr)-  = addExprCtxt rn_expr $-    setSrcSpanA loc     $-    do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr-       ; do_ql <- wantQuickLook rn_fun-       ; (tc_fun, fun_sigma) <- tcInferAppHead fun-       ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args-       ; _ <- tcValArgs do_ql inst_args-       ; return app_res_sigma }--{- *********************************************************************-*                                                                      *               Typechecking n-ary applications *                                                                      * ********************************************************************* -}@@ -218,9 +198,9 @@  A "head" has three special cases (for which we can infer a polytype using tcInferAppHead_maybe); otherwise is just any old expression (for-which we can infer a rho-type (via tcInfer).+which we can infer a rho-type (via runInferExpr). -There is no special treatment for HsUnboundVar, HsOverLit etc, because+There is no special treatment for HsHole (HsVar ...), HsOverLit, etc, because we can't get a polytype from them.  Left and right sections (e.g. (x +) and (+ x)) are not yet supported.@@ -402,13 +382,22 @@        -- Step 2: Infer the type of `fun`, the head of the application        ; (tc_fun, fun_sigma) <- tcInferAppHead fun        ; let tc_head = (tc_fun, fun_ctxt)+             -- inst_final: top-instantiate the result type of the application,+             -- EXCEPT if we are trying to infer a sigma-type+             inst_final = case exp_res_ty of+                             Check {} -> True+                             Infer (IR {ir_inst=iif}) ->+                                case iif of+                                  IIF_ShallowRho -> True+                                  IIF_DeepRho    -> True+                                  IIF_Sigma      -> False         -- Step 3: Instantiate the function type (taking a quick look at args)        ; do_ql <- wantQuickLook rn_fun        ; (inst_args, app_res_rho)               <- setQLInstLevel do_ql $  -- See (TCAPP1) and (TCAPP2) in                                          -- Note [tcApp: typechecking applications]-                 tcInstFun do_ql True tc_head fun_sigma rn_args+                 tcInstFun do_ql inst_final tc_head fun_sigma rn_args         ; case do_ql of             NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho)@@ -419,6 +408,7 @@                                                    app_res_rho exp_res_ty                          -- Step 4.2: typecheck the  arguments                        ; tc_args <- tcValArgs NoQL inst_args+                          -- Step 4.3: wrap up                        ; finishApp tc_head tc_args app_res_rho res_wrap } @@ -426,14 +416,17 @@                           -- Step 5.1: Take a quick look at the result type                        ; quickLookResultType app_res_rho exp_res_ty+                          -- Step 5.2: typecheck the arguments, and monomorphise                          --           any un-unified instantiation variables                        ; tc_args <- tcValArgs DoQL inst_args-                         -- Step 5.3: typecheck the arguments+                         -- Step 5.3: zonk to expose the polymophism hidden under+                         --           QuickLook instantiation variables in `app_res_rho`                        ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho+                          -- Step 5.4: subsumption check against the expected type                        ; res_wrap <- checkResultTy rn_expr tc_head inst_args-                                                   app_res_rho exp_res_ty+                                                    app_res_rho exp_res_ty                          -- Step 5.5: wrap up                        ; finishApp tc_head tc_args app_res_rho res_wrap } } @@ -459,20 +452,21 @@        ; res_expr <- if isTagToEnum tc_fun                      then tcTagToEnum tc_head tc_args app_res_rho                      else return (rebuildHsApps tc_head tc_args)+       ; traceTc "End tcApp }" (ppr tc_fun)        ; return (mkHsWrap res_wrap res_expr) } +-- | Connect up the inferred type of an application with the expected type.+-- This is usually just a unification, but with deep subsumption there is more to do. checkResultTy :: HsExpr GhcRn               -> (HsExpr GhcTc, AppCtxt)  -- Head               -> [HsExprArg p]            -- Arguments, just error messages               -> TcRhoType  -- Inferred type of the application; zonked to-                            --   expose foralls, but maybe not deeply instantiated+                            --   expose foralls, but maybe not /deeply/ instantiated               -> ExpRhoType -- Expected type; this is deeply skolemised               -> TcM HsWrapper--- Connect up the inferred type of the application with the expected type--- This is usually just a unification, but with deep subsumption there is more to do-checkResultTy _ _ _ app_res_rho (Infer inf_res)-  = do { co <- fillInferResult app_res_rho inf_res-       ; return (mkWpCastN co) }+checkResultTy rn_expr _fun _inst_args app_res_rho (Infer inf_res)+  = fillInferResult (exprCtOrigin rn_expr) app_res_rho inf_res+    -- fillInferResult does deep instantiation if DeepSubsumption is on  checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty) -- Unify with expected type from the context@@ -500,8 +494,6 @@              -- Even though both app_res_rho and res_ty are rho-types,              -- they may have nested polymorphism, so if deep subsumption              -- is on we must call tcSubType.-             -- Zonk app_res_rho first, because QL may have instantiated some-             -- delta variables to polytypes, and tcSubType doesn't expect that              do { wrap <- tcSubTypeDS rn_expr app_res_rho res_ty                 ; traceTc "checkResultTy 2 }" (ppr app_res_rho $$ ppr res_ty)                 ; return wrap } }@@ -614,7 +606,7 @@  -------------------- wantQuickLook :: HsExpr GhcRn -> TcM QLFlag-wantQuickLook (HsVar _ (L _ f))+wantQuickLook (HsVar _ (L _ (WithUserRdr _ f)))   | getUnique f `elem` quickLookKeys = return DoQL wantQuickLook _                      = do { impred <- xoptM LangExt.ImpredicativeTypes                                           ; if impred then return DoQL else return NoQL }@@ -630,18 +622,16 @@ ********************************************************************* -}  tcInstFun :: QLFlag-          -> Bool   -- False <=> Instantiate only /inferred/ variables at the end+          -> Bool   -- False <=> Instantiate only /top-level, inferred/ variables;                     --           so may return a sigma-type-                    -- True  <=> Instantiate all type variables at the end:-                    --           return a rho-type-                    -- The /only/ call site that passes in False is the one-                    --    in tcInferSigma, which is used only to implement :type-                    -- Otherwise we do eager instantiation; in Fig 5 of the paper+                    -- True  <=> Instantiate /top-level, invisible/ type variables;+                    --           always return a rho-type (but not a deep-rho type)+                    -- Generally speaking we pass in True; in Fig 5 of the paper                     --    |-inst returns a rho-type           -> (HsExpr GhcTc, AppCtxt)           -> TcSigmaType -> [HsExprArg 'TcpRn]           -> TcM ( [HsExprArg 'TcpInst]-                 , TcSigmaType )+                 , TcSigmaType )   -- Does not instantiate trailing invisible foralls -- This crucial function implements the |-inst judgement in Fig 4, plus the -- modification in Fig 5, of the QL paper: -- "A quick look at impredicativity" (ICFP'20).@@ -679,17 +669,13 @@      fun_is_out_of_scope  -- See Note [VTA for out-of-scope functions]       = case tc_fun of-          HsUnboundVar {} -> True+          HsHole _        -> True           _               -> False      inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool-    -- True <=> instantiate a tyvar with this ForAllTyFlag+    -- True <=> instantiate a tyvar that has this ForAllTyFlag     inst_fun [] | inst_final  = isInvisibleForAllTyFlag                 | otherwise   = const False-                -- Using `const False` for `:type` avoids-                -- `forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b`-                -- turning into `forall a {r2} (b :: TYPE r2). a -> b`.-                -- See #21088.     inst_fun (EValArg {} : _) = isInvisibleForAllTyFlag     inst_fun _                = isInferredForAllTyFlag @@ -904,7 +890,7 @@        ; case ctxt of            VACall fun arg_no _ | not in_generated_code              -> do setSrcSpanA arg_loc                    $-                     addErrCtxt (funAppCtxt fun arg arg_no) $+                     addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $                      thing_inside             VAExpansion (OrigStmt (L _ stmt@(BindStmt {}))) _ loc@@ -975,6 +961,7 @@       -- only parts of it are, e.g. `vfun (Maybe Int)` or `vfun (Maybe (type Int))`.       -- Apply a recursive T2T transformation.       HsWC [] <$> go e+        <* failIfErrsM   -- Suppress unhelpful errors that arise after a failed T2T   where     go :: LHsExpr GhcRn -> TcM (LHsType GhcRn)     go (L _ (HsEmbTy _ t)) =@@ -989,9 +976,9 @@          ; res' <- go res          ; return (L l (HsFunTy noExtField mult' arg' res'))}          where-          go_arrow :: HsArrowOf (LHsExpr GhcRn) GhcRn -> TcM (HsArrow GhcRn)-          go_arrow (HsUnrestrictedArrow{}) = pure (HsUnrestrictedArrow noExtField)-          go_arrow (HsLinearArrow{}) = pure (HsLinearArrow noExtField)+          go_arrow :: HsMultAnnOf (LHsExpr GhcRn) GhcRn -> TcM (HsMultAnn GhcRn)+          go_arrow (HsUnannotated _) = pure (HsUnannotated noExtField)+          go_arrow (HsLinearAnn{}) = pure (HsLinearAnn noExtField)           go_arrow (HsExplicitMult _ exp) = HsExplicitMult noExtField <$> go exp     go (L l (HsForAll _ tele expr)) =       do { ty <- go expr@@ -1001,9 +988,11 @@          ; ty <- go expr          ; return (L l (HsQualTy noExtField (L ann ctxt') ty)) }     go (L l (HsVar _ lname)) =-      -- as per #281: variables and constructors (regardless of their namespace)-      -- are mapped directly, without modification.-      return (L l (HsTyVar noAnn NotPromoted lname))+      -- GHC Proposal #281, section 7.5 "T2T-Mapping":+      --   variables and constructors (regardless of their namespace)+      --   are mapped directly, without modification.+      do { detect_puns lname+         ; return (L l (HsTyVar noAnn NotPromoted lname)) }     go (L l (HsApp _ lhs rhs)) =       do { lhs' <- go lhs          ; rhs' <- go rhs@@ -1055,7 +1044,7 @@       = do { t <- go (L l e)            ; let splice_result' = HsUntypedSpliceTop finalizers t            ; return (L l (HsSpliceTy splice_result' splice)) }-    go (L l (HsUnboundVar _ rdr))+    go (L l (HsHole (HoleVar (L _ rdr))))       | isUnderscore occ = return (L l (HsWildCardTy noExtField))       | startsWithUnderscore occ =           -- See Note [Wildcards in the T2T translation]@@ -1065,7 +1054,7 @@                else not_in_scope }       | otherwise = not_in_scope       where occ = occName rdr-            not_in_scope = failWith $ mkTcRnNotInScope rdr NotInScope+            not_in_scope = failWith $ TcRnNotInScope NotInScope rdr     go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) =       -- Use the original, user-written expression (before expansion).       -- Example. Say we have   vfun :: forall a -> blah@@ -1077,6 +1066,30 @@       go (L l orig)     go e = failWith $ TcRnIllformedTypeArgument e +    detect_puns :: LocatedN (WithUserRdr Name) -> TcM ()+      -- GHC Proposal #281, section 7.5 "T2T-Mapping":+      --   there should be no variable of the same name but from+      --   a different namespace, or else raise an ambiguity error+      --   (does not apply to constructors)+    detect_puns (L l (WithUserRdr rdr _))+      | isTermVarOrFieldNameSpace (rdrNameSpace rdr)+      , Just promoted_rdr <- promoteRdrName rdr+      = do { envs <- getRdrEnvs+           ; whenIsJust (lookup_rdr envs rdr) $ \unpromoted ->+             whenIsJust (lookup_rdr envs promoted_rdr) $ \promoted ->+               addErrAt (locA l) $+               TcRnIllegalPunnedVarOccInTypeArgument { illegalPunTermName = unpromoted+                                                     , illegalPunTypeName = promoted } }+      | otherwise = return ()++    lookup_rdr :: (GlobalRdrEnv, LocalRdrEnv) -> RdrName -> Maybe ResolvedNameInfo+    lookup_rdr (gbl_env, lcl_env) rdr+      | Just name <- lookupLocalRdrEnv lcl_env rdr+      = Just (ResolvedNameInfo [] rdr name)+      | gres@(gre:_) <- lookupGRE gbl_env (LookupRdrName rdr (RelevantGREsFOS WantNormal))+      = Just (ResolvedNameInfo gres rdr (gre_name gre))+      | otherwise = Nothing+     unwrap_wc :: HsWildCardBndrs GhcRn t -> TcM t     unwrap_wc (HsWC wcs t)       = do { mapM_ (illegal_wc . nameRdrName) wcs@@ -1127,7 +1140,7 @@       vfun [x | x <- xs]     Can't convert list comprehension to a type       vfun (\x -> x)         Can't convert a lambda to a type * It needs to check for LangExt.NamedWildCards to generate an appropriate-  error message for HsUnboundVar.+  error message for HsHole (HsVar ...).      vfun _a    Not in scope: ‘_a’                    (NamedWildCards disabled)      vfun _a    Illegal named wildcard in a required type argument: ‘_a’@@ -1189,20 +1202,19 @@        --        -- See [Wrinkle: VTA] in Note [Representation-polymorphism checking built-ins]        -- in GHC.Tc.Utils.Concrete.-       ; th_stage <- getStage+       ; th_lvl <- getThLevel        ; ty_arg <- case mb_conc of            Nothing   -> return ty_arg0            Just conc              -- See [Wrinkle: Typed Template Haskell]              -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.-             | Brack _ (TcPending {}) <- th_stage+             | TypedBrack {} <- th_lvl              -> return ty_arg0              | otherwise              ->              -- Example: user wrote e.g. (#,#) @(F Bool) for a type family F.              -- Emit [W] F Bool ~ kappa[conc] and pretend the user wrote (#,#) @kappa.-             do { mco <- unifyConcrete (occNameFS $ getOccName $ tv_nm) conc ty_arg0-                ; return $ case mco of { MRefl -> ty_arg0; MCo co -> coercionRKind co } }+               coercionRKind <$> unifyConcrete (occNameFS $ getOccName $ tv_nm) conc ty_arg0         ; let fun_ty    = mkForAllTy tvb inner_ty              in_scope  = mkInScopeSet (tyCoVarsOfTypes [fun_ty, ty_arg])@@ -1337,17 +1349,18 @@ Syntax of abstractions in Pat ----------------------------- * Type patterns are represented in Pat roughly like this-     data Pat = ConPat   ConLike [HsTyPat] [Pat]  -- (Con @tp1 @tp2 p1 p2)  (constructor pattern)-              | EmbTyPat HsTyPat                  -- (type tp)              (embed a type into a pattern with `type`)+     data Pat = ConPat   ConLike [Pat]  -- (Con @tp1 @tp2 p1 p2)  (constructor pattern)+              | EmbTyPat HsTyPat        -- (type tp)              (embed a type into a pattern with `type`)+              | InvisPat HsTyPat        -- (@tp)                  (invisible type pattern)               | ...      data HsTyPat = HsTP LHsType   (In ConPat, the type and term arguments are actually inside HsConPatDetails.) -  * Similar to HsAppType in HsExpr, the [HsTyPat] in ConPat is used just for @ty arguments+  * Similar to HsAppType in HsExpr, InvisPat in ConPat is used for @ty arguments   * Similar to HsEmbTy   in HsExpr, EmbTyPat lets you embed a type in a pattern  * Examples:-      \ (MkT @a  (x :: a)) -> rhs    -- ConPat (c.o. Pat) and HsConPatTyArg (c.o. HsConPatTyArg)+      \ (MkT @a  (x :: a)) -> rhs    -- ConPat (c.o. Pat) and InvisPat (c.o. Pat)       \ (type a) (x :: a)  -> rhs    -- EmbTyPat (c.o. Pat)       \ a        (x :: a)  -> rhs    -- VarPat (c.o. Pat)       \ @a       (x :: a)  -> rhs    -- InvisPat (c.o. Pat)@@ -1478,7 +1491,7 @@ Suppose 'wurble' is not in scope, and we have    (wurble @Int @Bool True 'x') -Then the renamer will make (HsUnboundVar "wurble") for 'wurble',+Then the renamer will make (HsHole (HsVar "wurble")) for 'wurble', and the typechecker will typecheck it with tcUnboundId, giving it a type 'alpha', and emitting a deferred Hole constraint, to be reported later.@@ -1493,7 +1506,7 @@ give its type.  Fortunately in tcInstFun we still have access to the function, so we-can check if it is a HsUnboundVar.  We use this info to simply skip+can check if it is a HsHole.  We use this info to simply skip over any visible type arguments.  We'll /already/ have emitted a Hole constraint; failing preserves that constraint. @@ -2038,22 +2051,22 @@       = go_flexi1 kappa ty2      go_flexi1 kappa ty2  -- ty2 is zonked-      | -- See Note [QuickLook unification] (UQL1)-        simpleUnifyCheck UC_QuickLook kappa ty2-      , checkTopShape (metaTyVarInfo kappa) ty2-          -- NB: don't forget to do a shape check, as we might be dealing-          -- with an ordinary metavariable (and not a quick-look instantiation variable).-          -- (Forgetting this led to #25950.)-      = do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind-                   -- unifyKind: see (UQL2) in Note [QuickLook unification]-                   --            and (MIV2) in Note [Monomorphise instantiation variables]-           ; let ty2' = mkCastTy ty2 co-           ; traceTc "qlUnify:update" $-             ppr kappa <+> text ":=" <+> ppr ty2-           ; liftZonkM $ writeMetaTyVar kappa ty2' }--      | otherwise-      = return ()   -- Occurs-check or forall-bound variable+      = do { cur_lvl <- getTcLevel+              -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles+              -- Here we are in the TcM monad, which does not track enclosing+              -- Given equalities; so for quick-look unification we conservatively+              -- treat /any/ level outside this one as untouchable. Hence cur_lvl.+           ; case simpleUnifyCheck UC_QuickLook cur_lvl kappa ty2 of+              SUC_CanUnify ->+                do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind+                           -- unifyKind: see (UQL2) in Note [QuickLook unification]+                           --            and (MIV2) in Note [Monomorphise instantiation variables]+                   ; let ty2' = mkCastTy ty2 co+                   ; traceTc "qlUnify:update" $+                     ppr kappa <+> text ":=" <+> ppr ty2+                   ; liftZonkM $ writeMetaTyVar kappa ty2' }+              _ -> return () -- e.g. occurs-check or forall-bound variable+           }       where         kappa_kind = tyVarKind kappa         ty2_kind   = typeKind ty2
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -40,7 +40,6 @@ import GHC.Types.Var.Set import GHC.Builtin.Types.Prim import GHC.Types.Basic( Arity )-import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -155,17 +154,17 @@         ; return (HsCmdPar x cmd') }  tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty-  = do  { (binds', _, body') <- tcLocalBinds binds         $-                                setSrcSpan (locA body_loc) $-                                tc_cmd env body res_ty+  = do  { (binds', body') <- tcLocalBinds binds         $+                             setSrcSpan (locA body_loc) $+                             tc_cmd env body res_ty         ; return (HsCmdLet x binds' (L body_loc body')) }  tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)-  = addErrCtxt (cmdCtxt in_cmd) $ do+  = addErrCtxt (CmdCtxt in_cmd) $ do     do { (scrut', scrut_ty) <- tcInferRho scrut        ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdCase) scrut_ty-       ; (mult_co_wrap, matches') <- tcCmdMatches env scrut_ty matches (stk, res_ty)-       ; return (HsCmdCase x (mkLHsWrap mult_co_wrap scrut') matches') }+       ; matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)+       ; return (HsCmdCase x scrut' matches') }  tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty    -- Ordinary 'if'   = do  { pred' <- tcCheckMonoExpr pred boolTy@@ -211,7 +210,7 @@ -- (plus -<< requires ArrowApply)  tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)-  = addErrCtxt (cmdCtxt cmd)    $+  = addErrCtxt (CmdCtxt cmd)    $     do  { arg_ty <- newOpenFlexiTyVarTy         ; let fun_ty = mkCmdArrTy env arg_ty res_ty         ; fun' <- select_arrow_scope (tcCheckMonoExpr fun fun_ty)@@ -242,7 +241,7 @@ -- D;G |-a cmd exp : stk --> res  tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)-  = addErrCtxt (cmdCtxt cmd)    $+  = addErrCtxt (CmdCtxt cmd)    $     do  { arg_ty <- newOpenFlexiTyVarTy         ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)         ; arg'   <- tcCheckMonoExpr arg arg_ty@@ -261,7 +260,7 @@ tc_cmd env cmd@(HsCmdLam x lam_variant match) cmd_ty   = (case lam_variant of   -- Add context only for \case and \cases         LamSingle -> id    -- Avoids clutter in the vanilla-lambda form-        _         -> addErrCtxt (cmdCtxt cmd)) $+        _         -> addErrCtxt (CmdCtxt cmd)) $     do { let match_ctxt = ArrowLamAlt lam_variant        ; arity <- checkArgCounts match        ; (wrap, match') <- tcCmdMatchLambda env match_ctxt arity match cmd_ty@@ -291,7 +290,7 @@ --      D; G |-a  (| e c1 ... cn |)  :  stk --> t  tc_cmd env cmd@(HsCmdArrForm fixity expr f cmd_args) (cmd_stk, res_ty)-  = addErrCtxt (cmdCtxt cmd)+  = addErrCtxt (CmdCtxt cmd)     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args                               -- We use alphaTyVar for 'w'         ; let e_ty = mkInfForAllTy alphaTyVar $@@ -317,7 +316,7 @@              -> TcTypeFRR -- ^ Type of the scrutinee.              -> MatchGroup GhcRn (LHsCmd GhcRn)  -- ^ case alternatives              -> CmdType-             -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))+             -> TcM (MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatches env scrut_ty matches (stk, res_ty)   = tcCaseMatches ctxt tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)   where@@ -339,7 +338,7 @@         ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys        ; matches' <- forM matches $-           addErrCtxt . pprMatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk'+           addErrCtxt . MatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk'         ; let arg_tys' = map unrestricted arg_tys              mg' = mg { mg_alts = L l matches'@@ -362,8 +361,8 @@     pg_ctxt    = PatGuard match_ctxt      tc_grhss (GRHSs x grhss binds) stk_ty res_ty-        = do { (binds', _, grhss') <- tcLocalBinds binds $-                                      mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss+        = do { (binds',grhss') <- tcLocalBinds binds $+                                  mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss              ; return (GRHSs x grhss' binds') }      tc_grhs stk_ty res_ty (GRHS x guards body)@@ -471,14 +470,3 @@  arrowTyConKind :: Kind          --  *->*->* arrowTyConKind = mkVisFunTysMany [liftedTypeKind, liftedTypeKind] liftedTypeKind--{--************************************************************************-*                                                                      *-                Errors-*                                                                      *-************************************************************************--}--cmdCtxt :: HsCmd GhcRn -> SDoc-cmdCtxt cmd = text "In the command:" <+> ppr cmd
compiler/GHC/Tc/Gen/Bind.hs view
@@ -59,8 +59,9 @@ import GHC.Core.FamInstEnv( normaliseType ) import GHC.Core.Class   ( Class ) import GHC.Core.Coercion( mkSymCo )-import GHC.Core.Type (mkStrLitTy, tidyOpenTypeX, mkCastTy)+import GHC.Core.Type (mkStrLitTy, mkCastTy) import GHC.Core.TyCo.Ppr( pprTyVars )+import GHC.Core.TyCo.Tidy( tidyOpenTypeX )  import GHC.Builtin.Types ( mkConstraintTupleTy, multiplicityTy, oneDataConTy  ) import GHC.Builtin.Types.Prim@@ -77,7 +78,6 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc -import GHC.Utils.Error import GHC.Utils.Misc import GHC.Types.Basic import GHC.Utils.Outputable as Outputable@@ -92,7 +92,7 @@ import GHC.Data.Maybe  import Control.Monad-import Data.Foldable (find)+import Data.Foldable (find, traverse_)  {- ************************************************************************@@ -192,14 +192,7 @@ -- The TcLclEnv has an extended type envt for the new bindings tcTopBinds binds sigs   = do  { -- Pattern synonym bindings populate the global environment-          (binds', wrap, (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs-        ; massertPpr (isIdHsWrapper wrap)-                     (text "Non-identity multiplicity wrapper at toplevel:" <+> ppr wrap)-          -- The wrapper (`wrap`) is always the identity because toplevel-          -- binders are unrestricted (and `tcSubmult _ ManyTy` returns the-          -- identity wrapper). Therefore it's safe to drop it altogether.-          ---          -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.+          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs         ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids  @@ -229,17 +222,16 @@  ------------------------ --- Why an HsWrapper? See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify. tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing-             -> TcM (HsLocalBinds GhcTc, HsWrapper, thing)+             -> TcM (HsLocalBinds GhcTc, thing)  tcLocalBinds (EmptyLocalBinds x) thing_inside   = do  { thing <- thing_inside-        ; return (EmptyLocalBinds x, idHsWrapper, thing) }+        ; return (EmptyLocalBinds x, thing) }  tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside-  = do  { (binds', wrapper, thing) <- tcValBinds NotTopLevel binds sigs thing_inside-        ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), wrapper, thing) }+  = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside+        ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"  tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside@@ -251,10 +243,7 @@         ; (ev_binds, result) <- checkConstraints (IPSkol ips)                                   [] given_ips thing_inside -        -- We don't have linear implicit parameters, yet. So the wrapper can be-        -- the identity.-        -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.-        ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , idHsWrapper, result) }+        ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }   where     ips = [ip | (L _ (IPBind _ (L _ ip) _)) <- ip_binds] @@ -265,26 +254,14 @@     tc_ip_bind ipClass (IPBind _ l_name@(L _ ip) expr)        = do { ty <- newFlexiTyVarTy liftedTypeKind  -- see #24298             ; let p = mkStrLitTy $ hsIPNameFS ip-            ; ip_id <- newDict ipClass [ p, ty ]+            ; ip_id <- newDict ipClass [p, ty]             ; expr' <- tcCheckMonoExpr expr ty-            ; let d = fmap (toDict ipClass p ty) expr'-            ; return (ip_id, (IPBind ip_id l_name d)) }--    -- Coerces a `t` into a dictionary for `IP "x" t`.-    -- co : t -> IP "x" t-    toDict :: Class  -- IP class-           -> Type   -- type-level string for name of IP-           -> Type   -- type of IP-           -> HsExpr GhcTc   -- def'n of IP variable-           -> HsExpr GhcTc   -- dictionary for IP-    toDict ipClass x ty = mkHsWrap $ mkWpCastR $-                          wrapIP $ mkClassPred ipClass [x,ty]+            ; return (ip_id, IPBind ip_id l_name expr') } --- Why an HsWrapper? See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify. tcValBinds :: TopLevelFlag            -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]            -> TcM thing-           -> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)+           -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)  tcValBinds top_lvl binds sigs thing_inside   = do  {   -- Typecheck the signatures@@ -303,7 +280,7 @@         -- For the moment, let bindings and top-level bindings introduce         -- only unrestricted variables.         ; tcExtendSigIds top_lvl poly_ids $-     do { (binds', wrapper, (extra_binds', thing))+     do { (binds', (extra_binds', thing))               <- tcBindGroups top_lvl sig_fn prag_fn binds $                  do { thing <- thing_inside                        -- See Note [Pattern synonym builders don't yield dependencies]@@ -312,17 +289,16 @@                     ; let extra_binds = [ (NonRecursive, builder)                                         | builder <- patsyn_builders ]                     ; return (extra_binds, thing) }-        ; return (binds' ++ extra_binds', wrapper, thing) }}+        ; return (binds' ++ extra_binds', thing) }}   where     patsyns = getPatSynBinds binds     prag_fn = mkPragEnv sigs (concatMap snd binds)  ------------------------ --- Why an HsWrapper? See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify. tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv              -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing-             -> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)+             -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time -- Here a "strongly connected component" has the straightforward@@ -331,16 +307,16 @@  tcBindGroups _ _ _ [] thing_inside   = do  { thing <- thing_inside-        ; return ([], idHsWrapper, thing) }+        ; return ([], thing) }  tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside   = do  { -- See Note [Closed binder groups]           type_env <- getLclTypeEnv         ; let closed = isClosedBndrGroup type_env (snd group)-        ; (group', outer_wrapper, (groups', inner_wrapper, thing))+        ; (group', (groups', thing))                 <- tc_group top_lvl sig_fn prag_fn group closed $                    tcBindGroups top_lvl sig_fn prag_fn groups thing_inside-        ; return (group' ++ groups', outer_wrapper <.> inner_wrapper, thing) }+        ; return (group' ++ groups', thing) }  -- Note [Closed binder groups] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -363,7 +339,7 @@ tc_group :: forall thing.             TopLevelFlag -> TcSigFun -> TcPragEnv          -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing-         -> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)+         -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)  -- Typecheck one strongly-connected component of the original program. -- We get a list of groups back, because there may@@ -377,9 +353,9 @@                  [bind] -> bind                  []     -> panic "tc_group: empty list of binds"                  _      -> panic "tc_group: NonRecursive binds is not a singleton bag"-       ; (bind', wrapper, thing) <- tc_single top_lvl sig_fn prag_fn bind closed-                                     thing_inside-       ; return ( [(NonRecursive, bind')], wrapper, thing) }+       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed+                             thing_inside+       ; return ( [(NonRecursive, bind')], thing) }  tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside   =     -- To maximise polymorphism, we do a new@@ -390,8 +366,8 @@     do  { traceTc "tc_group rec" (pprLHsBinds binds)         ; whenIsJust mbFirstPatSyn $ \lpat_syn ->             recursivePatSynErr (locA $ getLoc lpat_syn) binds-        ; (binds1, wrapper, thing) <- go sccs-        ; return ([(Recursive, binds1)], wrapper, thing) }+        ; (binds1, thing) <- go sccs+        ; return ([(Recursive, binds1)], thing) }                 -- Rec them all together   where     mbFirstPatSyn = find (isPatSyn . unLoc) binds@@ -401,15 +377,15 @@     sccs :: [SCC (LHsBind GhcRn)]     sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) -    go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, HsWrapper, thing)+    go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)     go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc                          -- recursive bindings must be unrestricted                          -- (the ids added to the environment here are the name of the recursive definitions).-                        ; ((binds2, inner_wrapper, thing), outer_wrapper) <-+                        ; (binds2, thing) <-                               tcExtendLetEnv top_lvl sig_fn closed ids1                               (go sccs)-                        ; return (binds1 ++ binds2, outer_wrapper <.> inner_wrapper, thing) }-    go []         = do  { thing <- thing_inside; return ([], idHsWrapper, thing) }+                        ; return (binds1 ++ binds2, thing) }+    go []         = do  { thing <- thing_inside; return ([], thing) }      tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]     tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds@@ -428,13 +404,13 @@ tc_single :: forall thing.             TopLevelFlag -> TcSigFun -> TcPragEnv           -> LHsBind GhcRn -> IsGroupClosed -> TcM thing-          -> TcM (LHsBinds GhcTc, HsWrapper, thing)+          -> TcM (LHsBinds GhcTc, thing) tc_single _top_lvl sig_fn prag_fn           (L loc (PatSynBind _ psb))           _ thing_inside   = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn        ; thing <- setGblEnv tcg_env thing_inside-       ; return (aux_binds, idHsWrapper, thing)+       ; return (aux_binds, thing)        }  tc_single top_lvl sig_fn prag_fn lbind closed thing_inside@@ -442,8 +418,8 @@                                       NonRecursive NonRecursive                                       closed                                       [lbind]-       ; (thing, wrapper) <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside-       ; return (binds1, wrapper, thing) }+       ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside+       ; return (binds1, thing) }  ------------------------ type BKey = Int -- Just number off the bindings@@ -503,8 +479,8 @@     ; let plan = decideGeneralisationPlan dflags top_lvl closed sig_fn bind_list     ; traceTc "Generalisation plan" (ppr plan)     ; result@(_, scaled_poly_ids) <- case plan of-         NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list-         InferGen           -> tcPolyInfer rec_tc prag_fn sig_fn bind_list+         NoGen              -> tcPolyNoGen         rec_tc prag_fn sig_fn bind_list+         InferGen           -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn bind_list          CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind      ; let poly_ids = map scaledThing scaled_poly_ids@@ -520,7 +496,7 @@     ; return result }   where     binder_names = collectHsBindListBinders CollNoDictBinders bind_list-    loc = foldr1 combineSrcSpans (map (locA . getLoc) bind_list)+    loc = foldr1WithDefault noSrcSpan combineSrcSpans (map (locA . getLoc) bind_list)          -- The mbinds have been dependency analysed and          -- may no longer be adjacent; so find the narrowest          -- span that includes them all@@ -606,11 +582,11 @@        -- the BinderStack, whence it shows up in "Relevant bindings.."        ; mono_name <- newNameAt (nameOccName name) (locA nm_loc) -       ; mult <- tcMultAnn (HsNoMultAnn noExtField)+       ; mult <- newMultiplicityVar        ; (wrap_gen, (wrap_res, matches'))              <- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty -> -                let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in+                let mono_id = mkLocalId mono_name (idMult poly_id) rho_ty in                 tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $                 -- Why mono_id in the BinderStack?                 -- See Note [Relevant bindings and the binder stack]@@ -738,12 +714,13 @@ -}  tcPolyInfer-  :: RecFlag       -- Whether it's recursive after breaking+  :: TopLevelFlag+  -> RecFlag       -- Whether it's recursive after breaking                    -- dependencies based on type signatures   -> TcPragEnv -> TcSigFun   -> [LHsBind GhcRn]   -> TcM (LHsBinds GhcTc, [Scaled TcId])-tcPolyInfer rec_tc prag_fn tc_sig_fn bind_list+tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn bind_list   = do { (tclvl, wanted, (binds', mono_infos))              <- pushLevelAndCaptureConstraints  $                 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list@@ -752,7 +729,7 @@         -- AbsBinds which are PatBinds can't be linear.        -- See (NVP2) in Note [Non-variable pattern bindings aren't linear]-       ; binds' <- manyIfPats binds'+       ; manyIfPats binds'         ; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos)) @@ -763,7 +740,7 @@         ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)        ; ((qtvs, givens, ev_binds, insoluble), residual)-            <- captureConstraints $ simplifyInfer tclvl infer_mode sigs name_taus wanted+            <- captureConstraints $ simplifyInfer top_lvl tclvl infer_mode sigs name_taus wanted         ; let inferred_theta = map evVarPred givens        ; scaled_exports <- checkNoErrs $@@ -790,17 +767,12 @@        ; return ([abs_bind], scaled_poly_ids) }          -- poly_ids are guaranteed zonked by mkExport   where-    manyIfPat bind@(L _ (PatBind{pat_lhs=(L _ (VarPat{}))}))-      = return bind-    manyIfPat (L loc pat@(PatBind {pat_mult=mult_ann, pat_lhs=lhs, pat_ext =(pat_ty,_)}))-      = do { mult_co_wrap <- tcSubMult (NonLinearPatternOrigin GeneralisedPatternReason nlWildPatName) ManyTy (getTcMultAnn mult_ann)-           -- The wrapper checks for correct multiplicities.-           -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.-           ; let lhs' = mkLHsWrapPat mult_co_wrap lhs pat_ty-           ; return $ L loc pat {pat_lhs=lhs'}-           }-    manyIfPat bind = return bind-    manyIfPats binds' = traverse manyIfPat binds'+    manyIfPat (L _ (PatBind{pat_lhs=(L _ (VarPat{}))}))+      = return ()+    manyIfPat (L _ (PatBind {pat_mult=mult_ann}))+      = tcSubMult (NonLinearPatternOrigin GeneralisedPatternReason nlWildPatName) ManyTy (getTcMultAnn mult_ann)+    manyIfPat _ = return ()+    manyIfPats binds' = traverse_ manyIfPat binds'  checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool -- True <=> apply the MR@@ -930,9 +902,11 @@         ; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty          -- NB: poly_id has a zonked type-        ; poly_id <- addInlinePrags poly_id prag_sigs-        ; spec_prags <- tcSpecPrags poly_id prag_sigs-                -- tcPrags requires a zonked poly_id+        ; poly_id    <- addInlinePrags poly_id prag_sigs+        ; spec_prags <- tcExtendIdEnv1 poly_name poly_id $+                        tcSpecPrags poly_id prag_sigs+                        -- tcSpecPrags requires a zonked poly_id.  It also needs poly_id to+                        -- be in the type env (so we can typecheck the SPECIALISE expression)          -- See Note [Impedance matching]         -- NB: we have already done checkValidType, including an ambiguity check,@@ -1151,12 +1125,10 @@ chooseInferredQuantifiers _ _ _ _ (Just sig)   = pprPanic "chooseInferredQuantifiers" (ppr sig) -mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc)+mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) mk_inf_msg poly_name poly_ty tidy_env  = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty-      ; let msg = vcat [ text "When checking the inferred type"-                       , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]-      ; return (tidy_env1, msg) }+      ; return (tidy_env1, InferredTypeCtxt poly_name poly_ty) }  -- | Warn the user about polymorphic local binders that lack type signatures. localSigWarn :: Id -> Maybe TcIdSigInst -> TcM ()@@ -1300,27 +1272,6 @@ to Integer because of Num. See #7173. If we're dealing with a nondefaultable class, impedance matching can fail. See #23427. -Note [SPECIALISE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~-There is no point in a SPECIALISE pragma for a non-overloaded function:-   reverse :: [a] -> [a]-   {-# SPECIALISE reverse :: [Int] -> [Int] #-}--But SPECIALISE INLINE *can* make sense for GADTS:-   data Arr e where-     ArrInt :: !Int -> ByteArray# -> Arr Int-     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)--   (!:) :: Arr e -> Int -> e-   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}-   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}-   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)-   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)--When (!:) is specialised it becomes non-recursive, and can usefully-be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE-for a non-overloaded function.- ************************************************************************ *                                                                      *                          tcMonoBinds@@ -1351,11 +1302,11 @@   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , Nothing <- sig_fn name   -- ...with no type signature   = setSrcSpanA b_loc    $-    do  { mult <- tcMultAnn (HsNoMultAnn noExtField)+    do  { mult <- newMultiplicityVar          ; ((co_fn, matches'), rhs_ty')-            <- tcInferFRR (FRRBinder name) $ \ exp_ty ->-                 -- tcInferFRR: the type of a let-binder must have+            <- runInferRhoFRR (FRRBinder name) $ \ exp_ty ->+                 -- runInferRhoFRR: the type of a let-binder must have                  -- a fixed runtime rep. See #23176                tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $                  -- We extend the error context even for a non-recursive@@ -1379,11 +1330,11 @@            [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_ann })]   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , all (isNothing . sig_fn) bndrs-  = addErrCtxt (patMonoBindsCtxt pat grhss) $-    do { mult <- tcMultAnn mult_ann+  = addErrCtxt (PatMonoBindsCtxt pat grhss) $+    do { mult <- tcMultAnnOnPatBind mult_ann -       ; (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ exp_ty ->-                          -- tcInferFRR: the type of each let-binder must have+       ; (grhss', pat_ty) <- runInferRhoFRR FRRPatBind $ \ exp_ty ->+                          -- runInferRhoFRR: the type of each let-binder must have                           -- a fixed runtime rep. See #23176                              tcGRHSsPat mult grhss exp_ty @@ -1547,12 +1498,12 @@     --           Just g = ...f...     -- Hence always typechecked with InferGen     do { mono_info <- tcLhsSigId no_gen (name, sig)-       ; mult <- tcMultAnn (HsNoMultAnn noExtField)+       ; mult <- newMultiplicityVar        ; return (TcFunBind mono_info (locA nm_loc) mult matches) }    | otherwise  -- No type signature   = do { mono_ty <- newOpenFlexiTyVarTy-       ; mult <- tcMultAnn (HsNoMultAnn noExtField)+       ; mult <- newMultiplicityVar        ; mono_id <- newLetBndr no_gen name mult mono_ty        ; let mono_info = MBI { mbi_poly_name = name                              , mbi_sig       = Nothing@@ -1567,11 +1518,11 @@         ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $                              [ (mbi_poly_name mbi, mbi_mono_id mbi)                              | mbi <- sig_mbis ]-        ; mult <- tcMultAnn mult_ann+        ; mult <- tcMultAnnOnPatBind mult_ann             -- See Note [Typechecking pattern bindings]         ; ((pat', nosig_mbis), pat_ty)-            <- addErrCtxt (patMonoBindsCtxt pat grhss) $-               tcInferFRR FRRPatBind $ \ exp_ty ->+            <- addErrCtxt (PatMonoBindsCtxt pat grhss) $+               runInferSigmaFRR FRRPatBind $ \ exp_ty ->                tcLetPat inst_sig_fun no_gen pat (Scaled mult exp_ty) $                  -- The above inferred type get an unrestricted multiplicity. It may be                  -- worth it to try and find a finer-grained multiplicity here@@ -1654,7 +1605,7 @@     -- That's why we have the special case for a single FunBind in tcMonoBinds     tcExtendIdBinderStackForRhs infos        $     do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)-        ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $+        ; grhss' <- addErrCtxt (PatMonoBindsCtxt pat' grhss) $                     tcGRHSsPat mult grhss (mkCheckExpType pat_ty)          ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'@@ -1662,13 +1613,13 @@                            , pat_mult = setTcMultAnn mult mult_ann } )}  --- | @'tcMultAnn' ann@ takes an optional multiplicity annotation. If+-- | @'tcMultAnnOnPatBind' ann@ takes an optional multiplicity annotation. If -- present the multiplicity is returned, otherwise a fresh unification variable -- is generated so that multiplicity can be inferred.-tcMultAnn :: HsMultAnn GhcRn -> TcM Mult-tcMultAnn (HsPct1Ann _) = return oneDataConTy-tcMultAnn (HsMultAnn _ p) = tcCheckLHsTypeInContext p (TheKind multiplicityTy)-tcMultAnn (HsNoMultAnn _) = newFlexiTyVarTy multiplicityTy+tcMultAnnOnPatBind :: HsMultAnn GhcRn -> TcM Mult+tcMultAnnOnPatBind (HsLinearAnn _) = return oneDataConTy+tcMultAnnOnPatBind (HsExplicitMult _ p) = tcCheckLHsTypeInContext p (TheKind multiplicityTy)+tcMultAnnOnPatBind (HsUnannotated _) = newMultiplicityVar  tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a tcExtendTyVarEnvForRhs Nothing thing_inside@@ -1892,7 +1843,7 @@       Just (TcIdSig (TcPartialSig {})) -> True       _                                -> False     has_mult_anns_and_pats = any has_mult_ann_and_pat lbinds-    has_mult_ann_and_pat (L _ (PatBind{pat_mult=HsNoMultAnn{}})) = False+    has_mult_ann_and_pat (L _ (PatBind{pat_mult=HsUnannotated{}})) = False     has_mult_ann_and_pat (L _ (PatBind{pat_lhs=(L _ (VarPat{}))})) = False     has_mult_ann_and_pat (L _ (PatBind{})) = True     has_mult_ann_and_pat _ = False@@ -1964,15 +1915,3 @@ applying to, well, local bindings. -} -{- *********************************************************************-*                                                                      *-               Error contexts and messages-*                                                                      *-********************************************************************* -}---- This one is called on LHS, when pat and grhss are both Name--- and on RHS, when pat is TcId and grhss is still Name-patMonoBindsCtxt :: (OutputableBndrId p)-                 => LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc-patMonoBindsCtxt pat grhss-  = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
compiler/GHC/Tc/Gen/Default.hs view
@@ -3,40 +3,46 @@ (c) The AQUA Project, Glasgow University, 1993-1998  -}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}  -- | Typechecking @default@ declarations-module GHC.Tc.Gen.Default ( tcDefaults ) where+module GHC.Tc.Gen.Default ( tcDefaultDecls, extendDefaultEnvWithLocalDefaults ) where  import GHC.Prelude- import GHC.Hs++import GHC.Builtin.Names import GHC.Core.Class-import GHC.Core.Type( typeKind )+import GHC.Core.Predicate ( Pred (..), classifyPredType ) -import GHC.Types.Var( tyVarKind )+import GHC.Data.Maybe ( firstJusts, maybeToList )+ import GHC.Tc.Errors.Types-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType-import GHC.Tc.Zonk.Type-import GHC.Tc.Solver-import GHC.Tc.Validity+import GHC.Tc.Solver.Monad  ( runTcS )+import GHC.Tc.Solver.Solve  ( solveWanteds )+import GHC.Tc.Types.Constraint ( isEmptyWC, andWC, mkSimpleWC )+import GHC.Tc.Types.Origin  ( CtOrigin(DefaultOrigin) )+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcMType ( newWanted ) import GHC.Tc.Utils.TcType-import GHC.Builtin.Names-import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), defaultEnv )-import GHC.Types.Error++import GHC.Types.Basic ( TypeOrKind(..) )+import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), lookupDefaultEnv, insertDefaultEnv, DefaultProvenance (..) ) import GHC.Types.SrcLoc-import GHC.Unit.Types (Module, bignumUnit, ghcInternalUnit, moduleUnit, primUnit)-import GHC.Utils.Misc (fstOf3, sndOf3)++import GHC.Unit.Types (ghcInternalUnit, moduleUnit)+ import GHC.Utils.Outputable+ import qualified GHC.LanguageExtensions as LangExt -import Control.Monad (void)-import Data.Function (on)-import Data.List.NonEmpty ( NonEmpty (..), groupBy )+import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE-+import Data.Traversable ( for )  {- Note [Named default declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -78,7 +84,7 @@ * The `DefaultEnv` of all defaults in scope in a module is kept in the `tcg_default`   field of `TcGblEnv`. -* This field is populated by `GHC.Tc.Gen.Default.tcDefaults` which typechecks+* This field is populated by `GHC.Tc.Gen.Default.tcDefaultDecls` which typechecks   any local or imported `default` declarations.  * Only a single default declaration can be in effect in any single module for@@ -95,7 +101,7 @@   in effect be `default Num (Integer, Double)` as specified by Haskell Language   Report. -  See Note [Default class defaults] in GHC.Tc.Utils.Env+  See Note [Builtin class defaults] in GHC.Tc.Utils.Env  * Beside the defaults, the `ExtendedDefaultRules` and `OverloadedStrings`   extensions also affect the traditional `default` declarations that don't name@@ -112,127 +118,229 @@   tracked separately from `ImportAvails`, and returned separately from them by   `GHC.Rename.Names.rnImports`. -* Class defaults are exported explicitly, as the example above shows. A module's-  exported defaults are tracked in `tcg_default_exports`, which are then-  transferred to `mg_defaults`, `md_defaults`, and `mi_defaults_`.+* Class defaults are exported explicitly.+  For example,+        module M( ..., default C, ... )+  exports the defaults for class C.++  A module's exported defaults are computed by exports_from_avail,+  tracked in tcg_default_exports, which are then transferred to mg_defaults,+  md_defaults, and mi_defaults_.++  Only defaults explicitly exported are actually exported.+  (i.e. No defaults are exported in a module header like:+          module M where ...)+   See Note [Default exports] in GHC.Tc.Gen.Export  * Since the class defaults merely help the solver infer the correct types, they   leave no trace in Haskell Core. -} --- See Note [Named default declarations]-tcDefaults :: [LDefaultDecl GhcRn]-           -> TcM DefaultEnv  -- Defaulting types to heave-                              -- into Tc monad for later use-                              -- in Disambig.+-- | Typecheck a collection of default declarations. These can be either:+--+--  - Haskell 98 default declarations, of the form @default (Float, Double)@+--  - Named default declarations, of the form @default Cls(Int, Char)@.+--    See Note [Named default declarations]+tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]+tcDefaultDecls decls =+  do+    tcg_env <- getGblEnv+    let here = tcg_mod tcg_env+        is_internal_unit = moduleUnit here == ghcInternalUnit+    case (is_internal_unit, decls) of+      -- No default declarations+      (_, []) -> return []+      -- As per Remark [default () in ghc-internal] in Note [Builtin class defaults],+      -- some modules in ghc-internal include an empty `default ()` declaration, in order+      -- to disable built-in defaults. This is no longer necessary (see `GHC.Tc.Utils.Env.tcGetDefaultTys`),+      -- but we must still make sure not to error if we fail to look up e.g. the 'Num'+      -- typeclass when typechecking such a default declaration. To do this, we wrap+      -- calls of 'tcLookupClass' in 'tryTc'.+      (True, [L _ (DefaultDecl _ Nothing [])]) -> do+        h2010_dflt_clss <- foldMapM (fmap maybeToList . fmap fst . tryTc . tcLookupClass) =<< getH2010DefaultNames+        case NE.nonEmpty h2010_dflt_clss of+          Nothing -> return []+          Just h2010_dflt_clss' -> toClassDefaults h2010_dflt_clss' decls+      -- Otherwise we take apart the declaration into the class constructor and its default types.+      _ -> do+        h2010_dflt_clss <- getH2010DefaultClasses+        toClassDefaults h2010_dflt_clss decls+  where+    getH2010DefaultClasses :: TcM (NonEmpty Class)+    -- All the classes subject to defaulting with a Haskell 2010 default+    -- declaration, of the form:+    --+    --   default (Int, Bool, Float)+    --+    -- Specifically:+    --    No extensions:       Num+    --    OverloadedStrings:   add IsString+    --    ExtendedDefaults:    add Show, Eq, Ord, Foldable, Traversable+    getH2010DefaultClasses = mapM tcLookupClass =<< getH2010DefaultNames+    getH2010DefaultNames+      = do { ovl_str   <- xoptM LangExt.OverloadedStrings+           ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules+           ; let deflt_str = if ovl_str+                              then [isStringClassName]+                              else []+           ; let deflt_interactive = if ext_deflt+                                  then interactiveClassNames+                                  else []+           ; let extra_clss_names = deflt_str ++ deflt_interactive+           ; return $ numClassName :| extra_clss_names+           }+    declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type]))+    declarationParts h2010_dflt_clss decl@(L locn (DefaultDecl _ mb_cls_name dflt_hs_tys))+      = setSrcSpan (locA locn) $+          case mb_cls_name of+            -- Haskell 98 default declaration+            Nothing ->+              do { tau_tys <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = True })+                            $ mapMaybeM (check_instance_any h2010_dflt_clss) dflt_hs_tys+                 ; return $ Just (Nothing, decl, tau_tys) }+            -- Named default declaration+            Just cls_name ->+              do { named_deflt <- xoptM LangExt.NamedDefaults+                 ; checkErr named_deflt (TcRnIllegalNamedDefault decl)+                 ; mb_cls <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = False })+                           $ tcDefaultDeclClass cls_name+                 ; for mb_cls $ \ cls ->+              do { tau_tys <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = True })+                            $ mapMaybeM (check_instance_any (NE.singleton cls)) dflt_hs_tys+                 ; return (Just cls, decl, tau_tys)+                 } } -tcDefaults []-  = getDeclaredDefaultTys       -- No default declaration, so get the-                                -- default types from the envt;-                                -- i.e. use the current ones-                                -- (the caller will put them back there)-        -- It's important not to return defaultDefaultTys here (which-        -- we used to do) because in a TH program, tcDefaults [] is called-        -- repeatedly, once for each group of declarations between top-level-        -- splices.  We don't want to carefully set the default types in-        -- one group, only for the next group to ignore them and install-        -- defaultDefaultTys+    toClassDefaults :: NonEmpty Class -> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]+    toClassDefaults h2010_dflt_clss dfs = do+        dfs <- mapMaybeM (declarationParts h2010_dflt_clss) dfs+        return $ concatMap (go False) dfs+      where+        go h98 = \case+          (Nothing, rn_decl, tys) -> concatMap (go True) [(Just cls, rn_decl, tys) | cls <- NE.toList h2010_dflt_clss]+          (Just cls, (L locn _), tys) -> [(L locn $ ClassDefaults cls tys (DP_Local (locA locn) h98) Nothing)] -tcDefaults decls-  = do  { ovl_str   <- xoptM LangExt.OverloadedStrings-        ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules-        ; deflt_str <- if ovl_str-                       then mapM tcLookupClass [isStringClassName]-                       else return []-        ; deflt_interactive <- if ext_deflt-                               then mapM tcLookupClass interactiveClassNames-                               else return []-        ; tcg_env <- getGblEnv-        ; let extra_clss = deflt_str ++ deflt_interactive-              here = tcg_mod tcg_env-              is_internal_unit = moduleUnit here `elem` [bignumUnit, ghcInternalUnit, primUnit]-        ; decls' <- case (is_internal_unit, decls) of-            -- Some internal GHC modules contain @default ()@ to declare that no defaults can take place-            -- in the module.-            -- We shortcut the treatment of such a default declaration with no class nor types: we won't-            -- try to point 'cd_class' to 'Num' since it may not even exist yet.-            (True, [L _ (DefaultDecl _ Nothing [])]) -> pure []-            -- Otherwise we take apart the declaration into the class constructor and its default types.-            _ ->  mapM (declarationParts extra_clss) decls-        ; defaultEnv . concat <$> mapM (reportDuplicates here extra_clss) (groupBy ((==) `on` sndOf3) decls') }+-- | Extend the default environment with the local default declarations+-- and do the action in the extended environment.+extendDefaultEnvWithLocalDefaults :: [LocatedA ClassDefaults] -> TcM a -> TcM a+extendDefaultEnvWithLocalDefaults decls action = do+  tcg_env <- getGblEnv+  let default_env = tcg_default tcg_env+  new_default_env <- insertDefaultDecls default_env decls+  updGblEnv (\gbl -> gbl { tcg_default = new_default_env } ) $ action++-- | Insert local default declarations into the default environment.+--+-- See 'insertDefaultDecl'.+insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv+insertDefaultDecls = foldrM insertDefaultDecl+-- | Insert a local default declaration into the default environment.+--+-- If the class already has a local default declaration in the DefaultEnv,+-- report an error and return the original DefaultEnv. Otherwise, override+-- any existing default declarations (e.g. imported default declarations).+--+-- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module+insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv+insertDefaultDecl (L decl_loc new_cls_defaults ) default_env =+  case lookupDefaultEnv default_env (className cls) of+    Just cls_defaults+      | DP_Local {} <- cd_provenance cls_defaults+      -> do { setSrcSpan (locA decl_loc) (addErrTc $ TcRnMultipleDefaultDeclarations cls cls_defaults)+            ; return default_env }+    _ -> return $ insertDefaultEnv new_cls_defaults default_env+      -- NB: this overrides imported and built-in default declarations+      -- for this class, if there were any.   where-    declarationParts :: [Class] -> LDefaultDecl GhcRn -> TcM (LDefaultDecl GhcRn, Class, [Type])-    reportDuplicates :: Module -> [Class] -> NonEmpty (LDefaultDecl GhcRn, Class, [Type]) -> TcM [ClassDefaults]-    declarationParts extra_clss decl@(L locn (DefaultDecl _ cls_tyMaybe mono_tys))-      = addErrCtxt defaultDeclCtxt $-        setSrcSpan (locA locn)     $-        do { tau_tys <- mapAndReportM tc_default_ty mono_tys-           ; def_clsCon <- case cls_tyMaybe of-               Nothing ->-                 do { numTyCls <- tcLookupClass numClassName-                    ; let classTyConAndArgKinds cls = (cls, [], tyVarKind <$> classTyVars cls)-                          tyConsAndArgKinds = (numTyCls, [], [liftedTypeKind]) :| map classTyConAndArgKinds extra_clss-                    ; void $ mapAndReportM (check_instance_any tyConsAndArgKinds) tau_tys-                    ; return numTyCls }-               Just cls_name ->-                 do { named_deflt <- xoptM LangExt.NamedDefaults-                    ; checkErr named_deflt (TcRnIllegalNamedDefault decl)-                    ; let cls_ty = noLocA (HsSig { sig_ext   = noExtField-                                                 , sig_bndrs = HsOuterImplicit{hso_ximplicit = []}-                                                 , sig_body  = noLocA $ HsTyVar noAnn NotPromoted cls_name})-                    ; (_cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDefault cls_ty-                    ; case cls_arg_kinds-                      of [k] -> void $ mapAndReportM (check_instance_any (NE.singleton (cls, cls_tys, [k]))) tau_tys-                         _ -> addErrTc (TcRnNonUnaryTypeclassConstraint DefaultDeclCtxt cls_ty)-                    ; return cls }-           ; return (decl, def_clsCon, tau_tys) }-    reportDuplicates here extra_clss ((_, clsCon, tys) :| [])-      = pure [ ClassDefaults{cd_class = c, cd_types = tys, cd_module = Just here, cd_warn = Nothing}-             | c <- clsCon : extra_clss ]-    -- Report an error on multiple default declarations for the same class in the same module.-    -- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module-    reportDuplicates _ _ decls@((L locn _, cls, _) :| _)-      = setSrcSpan (locA locn) (addErrTc $ dupDefaultDeclErr cls (fstOf3 <$> decls))-        >> pure []+    cls = cd_class new_cls_defaults -tc_default_ty :: LHsType GhcRn -> TcM Type-tc_default_ty hs_ty- = do   { ty <- solveEqualities "tc_default_ty" $-                tcInferLHsType hs_ty-        ; ty <- zonkTcTypeToType ty   -- establish Type invariants-        ; checkValidType DefaultDeclCtxt ty-        ; return ty } --- Check that the type is an instance of at least one of the default classes.--- Beside the class type constructor, we take the already-supplied type--- parameters and the expected kinds of the remaining parameters. We report--- an error unless there's only one remaining parameter to fill and the given--- type has the expected kind.-check_instance_any :: NonEmpty (Class, [Type], [Kind]) -> Type -> TcM ()+-- | Check that the type is an instance of at least one of the default classes.+--+-- See Note [Instance check for default declarations]+check_instance_any :: NonEmpty Class+                        -- ^ classes, all assumed to be unary+                   -> LHsType GhcRn+                        -- ^ default type+                   -> TcM (Maybe Type) check_instance_any deflt_clss ty- = do   { oks <- mapM (check_instance ty) deflt_clss-        ; checkTc (or oks) (TcRnBadDefaultType ty (NE.map fstOf3 deflt_clss))+  = do  { oks <- mapM (\ cls -> simplifyDefault cls ty) deflt_clss+        ; case firstJusts oks of+            Nothing ->+             do { addErrTc $ TcRnBadDefaultType ty deflt_clss+                ; return Nothing }+            Just ty ->+             return $ Just ty         } -check_instance :: Type -> (Class, [Type], [Kind]) -> TcM Bool--- Check that ty is an instance of cls--- We only care about whether it worked or not; return a boolean--- This checks that  cls :: k -> Constraint--- with just one argument and no polymorphism; if we need to add--- polymorphism we can make it more complicated.  For now we are--- concerned with classes like---    Num      :: Type -> Constraint---    Foldable :: (Type->Type) -> Constraint-check_instance ty (cls, clsArgs, [cls_argKind])-  | cls_argKind `tcEqType` typeKind ty-  = simplifyDefault [mkTyConApp (classTyCon cls) (clsArgs ++ [ty])]-check_instance _ _-  = return False+-- | Given a class @C@ and a type @ty@, is @C ty@ soluble?+--+-- Used to check that a type is an instance of a class in a default+-- declaration.+--+-- See Note [Instance check for default declarations] in GHC.Tc.Solver.Default.+simplifyDefault+  :: Class -- ^ class, assumed to be unary,i.e. it takes some invisible arguments+           -- and then a single (final) visible argument+  -> LHsType GhcRn -- ^ default type+  -> TcM (Maybe Type)+simplifyDefault cls dflt_ty@(L l _)+  = do { let app_ty :: LHsType GhcRn+             app_ty = L l $ HsAppTy noExtField (nlHsTyVar NotPromoted (className cls)) dflt_ty+       ; (inst_pred, wtds) <- captureConstraints $ tcCheckLHsType app_ty constraintKind+       ; wtd_inst <- newWanted DefaultOrigin (Just TypeLevel) inst_pred+       ; let all_wanteds = wtds `andWC` mkSimpleWC [wtd_inst]+       ; (unsolved, _) <- runTcS $ solveWanteds all_wanteds+       ; traceTc "simplifyDefault" $+           vcat [ text "cls:" <+> ppr cls+                , text "dflt_ty:" <+> ppr dflt_ty+                , text "inst_pred:" <+> ppr inst_pred+                , text "all_wanteds " <+> ppr all_wanteds+                , text "unsolved:" <+> ppr unsolved ]+       ; let is_instance = isEmptyWC unsolved+       ; return $+           if | is_instance+              , ClassPred _ tys <- classifyPredType inst_pred+              -- inst_pred looks like (C @k1 .. @kn t);+              -- we want the final (visible) argument `t`+              , Just tys_ne <- NE.nonEmpty tys+              -> Just $ NE.last tys_ne+              | otherwise+              -> Nothing+       } -defaultDeclCtxt :: SDoc-defaultDeclCtxt = text "When checking the types in a default declaration"+{- Note [Instance check for default declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see a named default declaration, such as: -dupDefaultDeclErr :: Class -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage-dupDefaultDeclErr cls (L _ DefaultDecl {} :| dup_things)-  = TcRnMultipleDefaultDeclarations cls dup_things+  default C(ty_1, ..., ty_n)++we must check that each of the types 'ty1', ..., 'ty_n' is an instance of+the class 'C'. For each individual type 'ty', the strategy is thus:++  - Create a new Wanted constraint 'C ty', and run the solver on it.+    The default declaration 'default C(ty)' is valid iff the solver succeeds+    in solving this constraint (with no residual unsolved Wanteds).++This is implemented in GHC.Tc.Gen.Default.check_instance, and tested in T25882.++The only slightly subtle point is that we want to allow classes such as++  Typeable :: forall k. k -> Constraint++which take invisible arguments and a (single) visible argument. The function+GHC.Tc.Gen.HsType.tcDefaultDeclClass checks that the class 'C' takes a single+visible parameter.++Note that Haskell98 default declarations, of the form++  default (ty_1, ..., ty_n)++work similarly, except that instead of checking for a single class, we check+whether each type is an instance of:++  - only the Num class, by default+  - ... or the IsString class, with -XOverloadedStrings+  - ... or any of the Show, Eq, Ord, Foldable, and Traversable classes,+        with -XExtendedDefaultRules+-}
compiler/GHC/Tc/Gen/Do.hs view
@@ -6,8 +6,6 @@ {-# LANGUAGE TupleSections    #-} {-# LANGUAGE TypeFamilies     #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -23,7 +21,8 @@  import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,                           genHsLamDoExp, genHsCaseAltDoExp, genWildPat )-import GHC.Rename.Env ( irrefutableConLikeRn )+import GHC.Rename.Env   ( irrefutableConLikeRn )+ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType 
compiler/GHC/Tc/Gen/Export.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE TypeFamilies       #-}+{-# LANGUAGE TupleSections      #-}  module GHC.Tc.Gen.Export (rnExports, exports_from_avail, classifyGREs) where @@ -21,12 +23,11 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName )-import GHC.Utils.Error+import GHC.Rename.Splice import GHC.Unit.Module import GHC.Unit.Module.Imported import GHC.Unit.Module.Warnings import GHC.Core.TyCon-import GHC.Utils.Misc (sndOf3, thdOf3) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Core.ConLike@@ -43,8 +44,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set-import GHC.Types.DefaultEnv (ClassDefaults (cd_class), DefaultEnv,-                             emptyDefaultEnv, filterDefaultEnv, isEmptyDefaultEnv)+import GHC.Types.DefaultEnv import GHC.Types.Avail import GHC.Types.SourceFile import GHC.Types.Id@@ -57,6 +57,7 @@ import Data.Traversable   ( for ) import Data.List ( sortBy ) import qualified Data.Map as Map+import GHC.Types.Unique.FM  {- ************************************************************************@@ -145,6 +146,8 @@      = ExportAccum {          expacc_exp_occs :: ExportOccMap,            -- ^ Tracks exported occurrence names+         expacc_exp_dflts :: NameEnv (ClassDefaults, IE GhcPs),+           -- ^ Tracks exported named default declarations          expacc_mods :: UniqMap ModuleName [Name],            -- ^ Tracks (re-)exported module names            --   and the names they re-export@@ -157,15 +160,16 @@   emptyExportAccum :: ExportAccum-emptyExportAccum = ExportAccum emptyOccEnv emptyUniqMap [] emptyNameEnv+emptyExportAccum = ExportAccum emptyOccEnv emptyNameEnv emptyUniqMap [] emptyNameEnv  accumExports :: (ExportAccum -> x -> TcRn (ExportAccum, Maybe y))              -> [x]-             -> TcRn ([y], ExportWarnSpanNames, DontWarnExportNames)+             -> TcRn ([y], DefaultEnv, ExportWarnSpanNames, DontWarnExportNames) accumExports f xs = do-  (ExportAccum _ _ export_warn_spans dont_warn_export, ys)+  (ExportAccum _ dflts _ export_warn_spans dont_warn_export, ys)     <- mapAccumLM f' emptyExportAccum xs   return ( catMaybes ys+         , fmap fst dflts          , export_warn_spans          , dont_warn_export )   where f' acc x@@ -218,7 +222,7 @@          -- Rename the export list         ; let do_it = exports_from_avail real_exports rdr_env imports this_mod-        ; (rn_exports, final_avails, new_export_warns)+        ; (rn_exports, default_env, final_avails, new_export_warns)             <- if hsc_src == HsigFile                 then do (mb_r, msgs) <- tryTc do_it                         case mb_r of@@ -228,17 +232,16 @@          -- Final processing         ; let final_ns = availsToNameSet final_avails-              drop_defaults (spans, _defaults, avails) = (spans, avails)          ; traceRn "rnExports: Exports:" (ppr final_avails)          ; return (tcg_env { tcg_exports    = final_avails                           , tcg_rn_exports = case tcg_rn_exports tcg_env of                                                 Nothing -> Nothing-                                                Just _  -> map drop_defaults <$> rn_exports+                                                Just _  -> rn_exports                           , tcg_default_exports = case exports of                               Nothing -> emptyDefaultEnv-                              _ -> foldMap (foldMap sndOf3) rn_exports+                              _ -> default_env                           , tcg_dus = tcg_dus tcg_env `plusDU`                                       usesOnly final_ns                           , tcg_warns = insertWarnExports@@ -280,7 +283,7 @@ would import the above `default IsString (Text, String)` declaration into the importing module. -The `cd_module` field of `ClassDefaults` tracks the module whence the default was+The `cd_provenance` field of `ClassDefaults` tracks the module whence the default was imported from, for the purpose of warning reports. The said warning report may be triggered by `-Wtype-defaults` or by a user-defined `WARNING` pragma attached to the default export. In the latter case the warning text is stored in the@@ -296,7 +299,7 @@                          -- @module Foo@ export is valid (it's not valid                          -- if we didn't import @Foo@!)                    -> Module-                   -> RnM (Maybe [(LIE GhcRn, DefaultEnv, Avails)], Avails, ExportWarnNames GhcRn)+                   -> RnM (Maybe [(LIE GhcRn, Avails)], DefaultEnv, Avails, ExportWarnNames GhcRn)                          -- (Nothing, _, _) <=> no explicit export list                          -- if explicit export list is present it contains                          -- each renamed export item together with its exported@@ -310,9 +313,9 @@     ; addDiagnostic         (TcRnMissingExportList $ moduleName _this_mod)     ; let avails =-            map fix_faminst . gresToAvailInfo+            map fix_faminst . gresToAvailInfo . mapMaybe pickLevelZeroGRE               . filter isLocalGRE . globalRdrEnvElts $ rdr_env-    ; return (Nothing, avails, []) }+    ; return (Nothing, emptyDefaultEnv, avails, []) }   where     -- #11164: when we define a data instance     -- but not data family, re-export the family@@ -328,14 +331,14 @@   exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod-  = do (ie_avails, export_warn_spans, dont_warn_export)+  = do (ie_avails, ie_dflts, export_warn_spans, dont_warn_export)          <- accumExports do_litem rdr_items-       let final_exports = nubAvails (concatMap thdOf3 ie_avails) -- Combine families+       let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families        export_warn_names <- aggregate_warnings export_warn_spans dont_warn_export-       return (Just ie_avails, final_exports, export_warn_names)+       return (Just ie_avails, ie_dflts, final_exports, export_warn_names)   where     do_litem :: ExportAccum -> LIE GhcPs-             -> RnM (ExportAccum, Maybe (LIE GhcRn, DefaultEnv, Avails))+             -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails))     do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie)      -- Maps a parent to its in-scope children@@ -356,9 +359,10 @@                        , imv <- importedByUser xs ]      exports_from_item :: ExportAccum -> LIE GhcPs-                      -> RnM (ExportAccum, Maybe (LIE GhcRn, DefaultEnv, Avails))+                      -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails))     exports_from_item expacc@ExportAccum{                         expacc_exp_occs   = occs,+                        expacc_exp_dflts  = exp_dflts,                         expacc_mods       = earlier_mods,                         expacc_warn_spans = export_warn_spans,                         expacc_dont_warn  = dont_warn_export@@ -381,6 +385,7 @@       = do { let { exportValid    = (mod `elem` imported_modules)                                   || (moduleName this_mod == mod)                  ; gre_prs        = pickGREsModExp mod (globalRdrEnvElts rdr_env)+                                    -- NB: this filters out non level 0 exports                  ; new_gres       = [ gre'                                     | (gre, _) <- gre_prs                                     , gre' <- expand_tyty_gre gre ]@@ -414,38 +419,41 @@                       (vcat [ ppr mod                             , ppr new_exports ])             ; return ( ExportAccum { expacc_exp_occs   = occs'+                                   , expacc_exp_dflts  = exp_dflts -- IEModuleContents does not re-export defaults                                    , expacc_mods       = mods                                    , expacc_warn_spans = export_warn_spans'                                    , expacc_dont_warn  = dont_warn_export' }-                     , Just (L loc (IEModuleContents warn_txt_rn lmod), emptyDefaultEnv, new_exports) ) }+                     , Just (L loc (IEModuleContents warn_txt_rn lmod), new_exports) ) }      exports_from_item acc lie = do         m_doc_ie <- lookup_doc_ie lie         case m_doc_ie of-          Just new_ie -> return (acc, Just (new_ie, emptyDefaultEnv, []))+          Just new_ie ->+            return (acc, Just (new_ie, []))           Nothing -> do             m_ie <- lookup_ie acc lie             case m_ie of               Nothing -> return (acc, Nothing)-              Just (acc', new_ie, Left cls) -> do-                defaults <- tcg_default <$> getGblEnv-                let exported_default = filterDefaultEnv ((cls ==) . nameOccName . className . cd_class) defaults-                return (acc', Just (new_ie, exported_default, []))-              Just (acc', new_ie, Right avail)-                -> return (acc', Just (new_ie, emptyDefaultEnv, [avail]))+              Just (acc', new_ie, mb_item) ->+                case mb_item of+                  Nothing ->+                    return (acc', Nothing)+                  Just avail ->+                    return (acc', Just (new_ie, [avail]))      --------------    lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, Either OccName AvailInfo))+    lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, Maybe AvailInfo))     lookup_ie expacc@ExportAccum{             expacc_exp_occs   = occs,             expacc_warn_spans = export_warn_spans,             expacc_dont_warn  = dont_warn_export           } (L loc ie@(IEVar warn_txt_ps l doc))-        = do mb_gre <- lookupGreAvailRn $ lieWrappedName l+        = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l              for mb_gre $ \ gre -> do                let avail = availFromGRE gre                    name = greName gre +               checkThLocalNameNoLift (ieLWrappedUserRdrName l name)                occs' <- check_occs occs ie [gre]                (export_warn_spans', dont_warn_export', warn_txt_rn)                  <- process_warning export_warn_spans@@ -459,19 +467,42 @@                               , expacc_warn_spans = export_warn_spans'                               , expacc_dont_warn  = dont_warn_export' }                       , L loc (IEVar warn_txt_rn (replaceLWrappedName l name) doc')-                      , Right avail )+                      , Just avail )      lookup_ie expacc@ExportAccum{             expacc_exp_occs   = occs,+            expacc_exp_dflts  = exp_dflts,             expacc_warn_spans = export_warn_spans,             expacc_dont_warn  = dont_warn_export           } (L loc ie@(IEThingAbs warn_txt_ps l doc))-        = do mb_gre <- lookupGreAvailRn $ lieWrappedName l+        = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l              for mb_gre $ \ gre -> do                let avail = availFromGRE gre                    name = greName gre -               occs' <- check_occs occs ie [gre]+               (mb_avail, occs', exp_dflts') <-+                 case unLoc l of+                   -- see Note [Default exports]+                   IEDefault {} -> do+                     defaults <- tcg_default <$> getGblEnv+                     case lookupUFM_Directly defaults (nameUnique name) of+                       Nothing ->+                        do addErr $ TcRnExportHiddenDefault ie+                           return (Nothing, occs, exp_dflts)+                       Just cls_dflts -> do+                         let cls = cd_class cls_dflts+                         case lookupNameEnv exp_dflts (className cls) of+                           Just (_, ie') -> do+                             addDiagnostic $+                               TcRnDuplicateNamedDefaultExport (classTyCon cls) ie ie'+                             return (Nothing, occs, exp_dflts)+                           Nothing ->+                            return $ (Nothing, occs, extendNameEnv exp_dflts (className cls) (cls_dflts, ie))+                   _ -> do+                    occs' <- check_occs occs ie [gre]+                    return (Just avail, occs', exp_dflts)++               checkThLocalNameNoLift (ieLWrappedUserRdrName l name)                (export_warn_spans', dont_warn_export', warn_txt_rn)                  <- process_warning export_warn_spans                                     dont_warn_export@@ -480,34 +511,26 @@                                     (locA loc)                 doc' <- traverse rnLHsDoc doc-               avail' <- case unLoc l of-                 -- see Note [Default exports]-                 IEDefault _ cls -> do-                   let defaultOccName = nameOccName . className . cd_class-                       occName = rdrNameOcc (unLoc cls)-                   defaults <- tcg_default <$> getGblEnv-                   when (isEmptyDefaultEnv $ filterDefaultEnv ((occName ==) . defaultOccName) defaults)-                        (addErr $ TcRnExportHiddenDefault ie)-                   pure (Left occName)-                 _ -> pure (Right avail)                return ( expacc{ expacc_exp_occs   = occs'+                              , expacc_exp_dflts  = exp_dflts'                               , expacc_warn_spans = export_warn_spans'                               , expacc_dont_warn  = dont_warn_export' }                       , L loc (IEThingAbs warn_txt_rn (replaceLWrappedName l name) doc')-                      , avail' )+                      , mb_avail )      lookup_ie expacc@ExportAccum{             expacc_exp_occs   = occs,             expacc_warn_spans = export_warn_spans,             expacc_dont_warn  = dont_warn_export           } (L loc ie@(IEThingAll (warn_txt_ps, ann) l doc))-        = do mb_gre <- lookupGreAvailRn $ lieWrappedName l+        = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l              for mb_gre $ \ par -> do                all_kids <- lookup_ie_kids_all ie l par                let name = greName par                    all_gres = par : all_kids                    all_names = map greName all_gres +               checkThLocalNameNoLift (ieLWrappedUserRdrName l name)                occs' <- check_occs occs ie all_gres                (export_warn_spans', dont_warn_export', warn_txt_rn)                  <- process_warning export_warn_spans@@ -521,18 +544,18 @@                               , expacc_warn_spans = export_warn_spans'                               , expacc_dont_warn  = dont_warn_export' }                       , L loc (IEThingAll (warn_txt_rn, ann) (replaceLWrappedName l name) doc')-                      , Right (AvailTC name all_names) )+                      , Just $ AvailTC name all_names )      lookup_ie expacc@ExportAccum{             expacc_exp_occs   = occs,             expacc_warn_spans = export_warn_spans,             expacc_dont_warn  = dont_warn_export           } (L loc ie@(IEThingWith (warn_txt_ps, ann) l wc sub_rdrs doc))-        = do mb_gre <- addExportErrCtxt ie-                     $ lookupGreAvailRn $ lieWrappedName l+        = do mb_gre <- addErrCtxt (ExportCtxt ie)+                     $ lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l              for mb_gre $ \ par -> do                (subs, with_kids)-                 <- addExportErrCtxt ie+                 <- addErrCtxt (ExportCtxt ie)                   $ lookup_ie_kids_with par sub_rdrs                 wc_kids <-@@ -545,6 +568,7 @@                    all_gres = par : all_kids                    all_names = map greName all_gres +               checkThLocalNameNoLift (ieLWrappedUserRdrName l name)                occs' <- check_occs occs ie all_gres                (export_warn_spans', dont_warn_export', warn_txt_rn)                  <- process_warning export_warn_spans@@ -558,7 +582,7 @@                               , expacc_warn_spans = export_warn_spans'                               , expacc_dont_warn  = dont_warn_export' }                       , L loc (IEThingWith (warn_txt_rn, ann) (replaceLWrappedName l name) wc subs doc')-                      , Right (AvailTC name all_names) )+                      , Just $ AvailTC name all_names )      lookup_ie _ _ = panic "lookup_ie"    -- Other cases covered earlier @@ -566,23 +590,24 @@     lookup_ie_kids_with :: GlobalRdrElt -> [LIEWrappedName GhcPs]                    -> RnM ([LIEWrappedName GhcRn], [GlobalRdrElt])     lookup_ie_kids_with gre sub_rdrs =-      do { let name = greName gre-         ; kids <- lookupChildrenExport name sub_rdrs+      do { kids <- lookupChildrenExport gre sub_rdrs          ; return (map fst kids, map snd kids) }      lookup_ie_kids_all :: IE GhcPs -> LIEWrappedName GhcPs -> GlobalRdrElt                   -> RnM [GlobalRdrElt]-    lookup_ie_kids_all ie (L _ rdr) gre =+    lookup_ie_kids_all ie (L _loc rdr) gre =       do { let name = greName gre                gres = findChildren kids_env name-         ; addUsedKids (ieWrappedName rdr) gres-         ; when (null gres) $+         -- We only choose level 0 exports when filling in part of an export list implicitly.+         ; let kids_0 = mapMaybe pickLevelZeroGRE gres+         ; addUsedKids (ieWrappedName rdr) kids_0+         ; when (null kids_0) $             if isTyConName name             then addTcRnDiagnostic (TcRnDodgyExports gre)             else -- This occurs when you export T(..), but                  -- only import T abstractly, or T is a synonym.                  addErr (TcRnExportHiddenComponents ie)-         ; return gres }+         ; return kids_0 }      ------------- @@ -679,6 +704,23 @@     addUsedKids parent_rdr kid_gres       = addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres) ++ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> Name -> LIdOccP GhcRn+ieLWrappedUserRdrName l n = fmap (\rdr -> WithUserRdr rdr n) $ ieLWrappedName l++-- | In what namespaces should we go looking for an import/export item+-- that is out of scope, for suggestions in error messages?+ieWrappedNameWhatLooking :: IEWrappedName GhcPs -> WhatLooking+ieWrappedNameWhatLooking = \case+  IEName {}    -> WL_TyCon_or_TermVar+  IEDefault {} -> WL_TyCon+  IEType {}    -> WL_Type+  IEData {}    -> WL_Term+  IEPattern {} -> WL_ConLike++ieLWrappedNameWhatLooking :: LIEWrappedName GhcPs -> WhatLooking+ieLWrappedNameWhatLooking = ieWrappedNameWhatLooking . unLoc+ -- Renaming and typechecking of exports happens after everything else has -- been typechecked. @@ -689,14 +731,14 @@  >> An abbreviated form of module, consisting only of the module body, is >> permitted. If this is used, the header is assumed to be->> ‘module Main(main) where’.+>> 'module Main(main) where'.  For modules without a module header, this is implemented the following way:  If the module has a main function in scope:    Then create a module header and export the main function,-   as if a module header like ‘module Main(main) where...’ would exist.+   as if a module header like 'module Main(main) where...' would exist.    This has the effect to mark the main function and all top level    functions called directly or indirectly via main as 'used',    and later on, unused top-level functions can be reported correctly.@@ -710,7 +752,7 @@    In GHCi this has the effect, that we don't get any 'non-used' warnings.    In GHC, however, the 'has-main-module' check in GHC.Tc.Module.checkMain    fires, and we get the error:-      The IO action ‘main’ is not defined in module ‘Main’+      The IO action 'main' is not defined in module 'Main' -}  @@ -739,27 +781,21 @@   -lookupChildrenExport :: Name -> [LIEWrappedName GhcPs]+lookupChildrenExport :: GlobalRdrElt+                     -> [LIEWrappedName GhcPs]                      -> RnM ([(LIEWrappedName GhcRn, GlobalRdrElt)])-lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items+lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items     where+        spec_parent = greName parent_gre         -- Process an individual child         doOne :: LIEWrappedName GhcPs               -> RnM (LIEWrappedName GhcRn, GlobalRdrElt)         doOne n = do            let bareName = (ieWrappedName . unLoc) n-              what_lkup :: LookupChild-              what_lkup =-                LookupChild-                  { wantedParent       = spec_parent-                  , lookupDataConFirst = True-                  , prioritiseParent   = False -- See T11970.-                  }-                 -- Do not report export list declaration deprecations           name <-  lookupSubBndrOcc_helper False ExportDeprecationWarnings-                        spec_parent bareName what_lkup+                        (ParentGRE spec_parent (greInfo parent_gre)) bareName           traceRn "lookupChildrenExport" (ppr name)           -- Default to data constructors for slightly better error           -- messages@@ -770,15 +806,16 @@            case name of             NameNotFound ->-              do { ub <- reportUnboundName unboundName+              do { ub <- reportUnboundName (lookingForSubordinate parent_gre) unboundName                  ; let l = getLoc n                        gre = mkLocalGRE UnboundGRE NoParent ub                  ; return (L l (IEName noExtField (L (l2l l) ub)), gre)}             FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) ->               do { checkPatSynParent spec_parent par child_nm+                 ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm)                  ; return (replaceLWrappedName n child_nm, child)                  }-            IncorrectParent p c gs -> failWithDcErr p (greName c) gs+            IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs   -- Note [Typing Pattern Synonym Exports]@@ -861,16 +898,13 @@        ; case mpat_syn_thing of             AnId i | isId i                    , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i-                   -> handle_pat_syn (selErr nm) parent_ty_con p+                   -> handle_pat_syn (PatSynRecSelExportCtxt p nm) parent_ty_con p -            AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p+            AConLike (PatSynCon p) -> handle_pat_syn (PatSynExportCtxt p) parent_ty_con p              _ -> failWithDcErr parent nm [] }   where-    psErr  = exportErrCtxt "pattern synonym"-    selErr = exportErrCtxt "pattern synonym record selector"--    handle_pat_syn :: SDoc+    handle_pat_syn :: ErrCtxtMsg                    -> TyCon      -- Parent TyCon                    -> PatSyn     -- Corresponding bundled PatSyn                                  -- and pretty printed origin@@ -974,18 +1008,6 @@     single IEThingAbs {} = True     single _             = False -exportErrCtxt :: Outputable o => String -> o -> SDoc-exportErrCtxt herald exp =-  text "In the" <+> text (herald ++ ":") <+> ppr exp---addExportErrCtxt :: (OutputableBndrId p)-                 => IE (GhcPass p) -> TcM a -> TcM a-addExportErrCtxt ie = addErrCtxt exportCtxt-  where-    exportCtxt = text "In the export:" <+> ppr ie-- failWithDcErr :: Name -> Name -> [Name] -> TcM a failWithDcErr parent child parents = do   ty_thing <- tcLookupGlobal child@@ -1017,7 +1039,7 @@                            -> RnM () addDuplicateFieldExportErr gre others   = do { rdr_env <- getGlobalRdrEnv-       ; let lkup = expectJust "addDuplicateFieldExportErr" . lookupGRE_Name rdr_env+       ; let lkup = expectJust . lookupGRE_Name rdr_env              other_gres = fmap (first lkup) others        ; addErr (TcRnDuplicateFieldExport gre other_gres) } 
compiler/GHC/Tc/Gen/Expr.hs view
@@ -19,7 +19,7 @@        ( tcCheckPolyExpr, tcCheckPolyExprNC,          tcCheckMonoExpr, tcCheckMonoExprNC,          tcMonoExpr, tcMonoExprNC,-         tcInferRho, tcInferRhoNC,+         tcInferExpr, tcInferSigma, tcInferRho, tcInferRhoNC,          tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig,          tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,          tcCheckId,@@ -34,59 +34,66 @@  import GHC.Hs import GHC.Hs.Syn.Type+ import GHC.Rename.Utils-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Unify-import GHC.Types.Basic-import GHC.Types.Error-import GHC.Types.FieldLabel-import GHC.Types.Unique.FM-import GHC.Types.Unique.Map-import GHC.Types.Unique.Set-import GHC.Core.Multiplicity-import GHC.Core.UsageEnv-import GHC.Tc.Errors.Types-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep )-import GHC.Tc.Utils.Instantiate+import GHC.Rename.Env         ( addUsedGRE, getUpdFieldLbls )+ import GHC.Tc.Gen.App import GHC.Tc.Gen.Head import GHC.Tc.Gen.Bind        ( tcLocalBinds )-import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )-import GHC.Core.FamInstEnv    ( FamInstEnvs )-import GHC.Rename.Env         ( addUsedGRE, getUpdFieldLbls )-import GHC.Tc.Utils.Env+import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Arrow import GHC.Tc.Gen.Match( tcBody, tcLambdaMatches, tcCaseMatches-                       , tcGRHSList, tcDoStmts )-import GHC.Tc.Gen.HsType-import GHC.Tc.Utils.TcMType+                       , tcGRHSNE, tcDoStmts )+import GHC.Tc.Instance.Family ( tcGetFamInstEnvs ) import GHC.Tc.Zonk.TcType-import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType as TcType-import GHC.Types.Id-import GHC.Types.Id.Info+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Unify+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep )+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Utils.Env+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Evidence+import GHC.Tc.Errors.Types hiding (HoleError)++import GHC.Core.Multiplicity+import GHC.Core.UsageEnv+import GHC.Core.FamInstEnv    ( FamInstEnvs ) import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Types.Name.Reader import GHC.Core.Class(classTyCon) import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion-import GHC.Tc.Types.Evidence+import GHC.Core.Predicate( decomposeIPPred )++import GHC.Types.Basic+import GHC.Types.Unique.FM+import GHC.Types.Unique.Map+import GHC.Types.Unique.Set+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc+ import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Builtin.Uniques ( mkBuiltinUnique )+ import GHC.Driver.DynFlags-import GHC.Types.SrcLoc+ import GHC.Utils.Misc-import GHC.Data.List.SetOps-import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Data.List.SetOps+import GHC.Data.Maybe+ import Control.Monad import qualified Data.List.NonEmpty as NE @@ -226,17 +233,24 @@ *                                                                      * ********************************************************************* -} +tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)+tcInferSigma = tcInferExpr IIF_Sigma+ tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated.-tcInferRho (L loc expr)-  = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad+tcInferRho   = tcInferExpr   IIF_DeepRho+tcInferRhoNC = tcInferExprNC IIF_DeepRho++tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)+tcInferExpr iif (L loc expr)+  = setSrcSpanA loc  $  -- Set location /first/; see GHC.Tc.Utils.Monad     addExprCtxt expr $  -- Note [Error contexts in generated code]-    do { (expr', rho) <- tcInfer (tcExpr expr)+    do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr)        ; return (L loc expr', rho) } -tcInferRhoNC (L loc expr)-  = setSrcSpanA loc $-    do { (expr', rho) <- tcInfer (tcExpr expr)+tcInferExprNC iif (L loc expr)+  = setSrcSpanA loc  $+    do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr)        ; return (L loc expr', rho) }  ---------------@@ -296,23 +310,19 @@  tcExpr (XExpr e)                 res_ty = tcXExpr e res_ty -tcExpr e@(HsOverLit _ lit) res_ty-  = do { mb_res <- tcShortCutLit lit res_ty-         -- See Note [Short cut for overloaded literals] in GHC.Tc.Zonk.Type-       ; case mb_res of-           Just lit' -> return (HsOverLit noExtField lit')-           Nothing   -> tcApp e res_ty }- -- Typecheck an occurrence of an unbound Id -- -- Some of these started life as a true expression hole "_".--- Others might simply be variables that accidentally have no binding site-tcExpr (HsUnboundVar _ occ) res_ty+-- Others might simply be variables that accidentally have no binding site.+tcExpr (HsHole (HoleVar locc@(L _ occ))) res_ty   = do { ty <- expTypeToType res_ty    -- Allow Int# etc (#12531)        ; her <- emitNewExprHole occ ty        ; tcEmitBindingUsage bottomUE   -- Holes fit any usage environment                                        -- (#18491)-       ; return (HsUnboundVar her occ) }+       ; return (HsHole (HoleVar locc, her))+       }+tcExpr (HsHole HoleError) _ =+  panic "GHC.Tc.Gen.Expr: tcExpr: HoleError: Not implemented"  tcExpr e@(HsLit x lit) res_ty   = do { let lit_ty = hsLitType lit@@ -338,16 +348,15 @@           -- Create a unification type variable of kind 'Type'.           -- (The type of an implicit parameter must have kind 'Type'.)        ; let ip_name = mkStrLitTy (hsIPNameFS x)-       ; ipClass <- tcLookupClass ipClassName-       ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])+             origin  = IPOccOrigin x+       ; ip_class <- tcLookupClass ipClassName+       ; let ip_pred = mkClassPred ip_class [ip_name, ip_ty]+       ; ip_dict <- emitWantedEvVar origin ip_pred+       ; let (ip_op, _) = decomposeIPPred ip_pred+             wrap = mkWpEvVarApps [ip_dict] <.> mkWpTyApps [ip_name, ip_ty]        ; tcWrapResult e-                   (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var)))-                   ip_ty res_ty }-  where-  -- Coerces a dictionary for `IP "x" t` into `t`.-  fromDict ipClass x ty = mkHsWrap $ mkWpCastR $-                          unwrapIP $ mkClassPred ipClass [x,ty]-  origin = IPOccOrigin x+               (mkHsWrap wrap (mkHsVar (noLocA ip_op)))+               ip_ty res_ty }  tcExpr e@(HsLam x lam_variant matches) res_ty   = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty@@ -356,6 +365,51 @@ {- ************************************************************************ *                                                                      *+                Overloaded literals+*                                                                      *+************************************************************************+-}++tcExpr e@(HsOverLit _ lit) res_ty+  = -- See Note [Typechecking overloaded literals]+    do { mb_res <- tcShortCutLit lit res_ty+         -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType+       ; case mb_res of+           Just lit' -> return (HsOverLit noExtField lit')+           Nothing   -> tcApp e res_ty }+           -- Why go via tcApp? See Note [Typechecking overloaded literals]++{- Note [Typechecking overloaded literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, an overloaded literal like "3" typechecks as if you+had written (fromInteger (3 :: Integer)).   But in practice it's a little+tricky:++* Rebindable syntax (see #19154 and !4981). With rebindable syntax we might have+     fromInteger :: Integer -> forall a. Num a => a+  and then we might hope to use a Visible Type Application (VTA) to write+     3 @Int+  expecting it to expand to+     fromInteger (3::Integer) @Int dNumInt+  To achieve that, we need to+    * treat the application using `tcApp` to deal with the VTA+    * treat the overloaded literal as the "head" of an application;+      see `GHC.Tc.Gen.Head.tcInferAppHead`.++* Short-cutting.  If we have+     xs :: [Int]+     xs = [3,4,5,6... ]+  then it's a huge short-cut (in compile time) to just cough up the `Int` literal+  for `3`, rather than (fromInteger @Int d), with a wanted constraint `[W] Num Int`.+  See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType.++  We can only take this short-cut if rebindable syntax is off; see `tcShortCutLit`.+-}+++{-+************************************************************************+*                                                                      *                 Explicit lists *                                                                      * ************************************************************************@@ -431,11 +485,9 @@ -}  tcExpr (HsLet x binds expr) res_ty-  = do  { (binds', wrapper, expr') <- tcLocalBinds binds $-                                      tcMonoExpr expr res_ty-          -- The wrapper checks for correct multiplicities.-          -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.-        ; return (HsLet x binds' (mkLHsWrap wrapper expr')) }+  = do  { (binds', expr') <- tcLocalBinds binds $+                             tcMonoExpr expr res_ty+        ; return (HsLet x binds' expr') }  tcExpr (HsCase ctxt scrut matches) res_ty   = do  {  -- We used to typecheck the case alternatives first.@@ -458,8 +510,8 @@         ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut          ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty-        ; (mult_co_wrap, matches') <- tcCaseMatches ctxt tcBody (Scaled mult scrut_ty) matches res_ty-        ; return (HsCase ctxt (mkLHsWrap mult_co_wrap scrut') matches') }+        ; matches' <- tcCaseMatches ctxt tcBody (Scaled mult scrut_ty) matches res_ty+        ; return (HsCase ctxt scrut' matches') }  tcExpr (HsIf x pred b1 b2) res_ty   = do { pred'    <- tcCheckMonoExpr pred boolTy@@ -493,7 +545,7 @@ -}  tcExpr (HsMultiIf _ alts) res_ty-  = do { alts' <- tcGRHSList IfAlt tcBody alts res_ty+  = do { alts' <- tcGRHSNE IfAlt tcBody alts res_ty                   -- See Note [MultiWayIf linearity checking]        ; res_ty <- readExpType res_ty        ; return (HsMultiIf res_ty alts') }@@ -517,10 +569,8 @@   = do  { res_ty          <- expTypeToType res_ty         ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty         ; (expr', lie)    <- captureConstraints $-            addErrCtxt (hang (text "In the body of a static form:")-                             2 (ppr expr)-                       ) $-            tcCheckPolyExprNC expr expr_ty+            addErrCtxt (StaticFormCtxt expr) $+              tcCheckPolyExprNC expr expr_ty          -- Check that the free variables of the static form are closed.         -- It's OK to use nonDetEltsUniqSet here as the only side effects of@@ -563,11 +613,11 @@ ************************************************************************ -} -tcExpr expr@(RecordCon { rcon_con = L loc con_name+tcExpr expr@(RecordCon { rcon_con = L loc qcon@(WithUserRdr _ con_name)                        , rcon_flds = rbinds }) res_ty-  = do  { con_like <- tcLookupConLike con_name+  = do  { con_like <- tcLookupConLike qcon -        ; (con_expr, con_sigma) <- tcInferId con_name+        ; (con_expr, con_sigma) <- tcInferConLike con_like         ; (con_wrap, con_tau)   <- topInstantiate orig con_sigma               -- a shallow instantiation should really be enough for               -- a data constructor.@@ -577,12 +627,7 @@         ; checkTc (conLikeHasBuilder con_like) $           nonBidirectionalErr (conLikeName con_like) -        ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds-                   -- It is currently not possible for a record to have-                   -- multiplicities. When they do, `tcRecordBinds` will take-                   -- scaled types instead. Meanwhile, it's safe to take-                   -- `scaledThing` above, as we know all the multiplicities are-                   -- Many.+        ; rbinds' <- tcRecordBinds con_like arg_tys rbinds          ; let rcon_tc = mkHsWrap con_wrap con_expr               expr' = RecordCon { rcon_ext = rcon_tc@@ -675,7 +720,7 @@ -- Here we get rid of it and add the finalizers to the global environment. -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. tcExpr (HsTypedSplice ext splice)   res_ty = tcTypedSplice ext splice res_ty-tcExpr e@(HsTypedBracket _ body)    res_ty = tcTypedBracket e body res_ty+tcExpr e@(HsTypedBracket _ext body)    res_ty = tcTypedBracket e body res_ty  tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty tcExpr (HsUntypedSplice splice _)   res_ty@@ -719,12 +764,12 @@ tcXExpr xe@(ExpandedThingRn o e') res_ty   | OrigStmt ls@(L loc s@LetStmt{}) <- o   , HsLet x binds e <- e'-  =  do { (binds', wrapper, e') <-  setSrcSpanA loc $-                            addStmtCtxt s $-                            tcLocalBinds binds $-                            tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds-                                                  -- a duplicate error context-        ; return $ mkExpandedStmtTc ls (HsLet x binds' (mkLHsWrap wrapper e'))+  =  do { (binds', e') <-  setSrcSpanA loc $+                           addStmtCtxt s $+                           tcLocalBinds binds $+                           tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds+                                                 -- a duplicate error context+        ; return $ mkExpandedStmtTc ls (HsLet x binds' e')         }   | OrigStmt ls@(L loc s@LastStmt{}) <- o   =  setSrcSpanA loc $@@ -737,6 +782,7 @@   | OrigStmt ls@(L loc _) <- o   = setSrcSpanA loc $        mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty+ tcXExpr xe res_ty = tcApp (XExpr xe) res_ty  {-@@ -839,7 +885,7 @@          ; return (Missing (Scaled mult arg_ty), arg_ty) }   tc_infer_tup_arg i (Present x lexpr@(L l expr))     = do { (expr', arg_ty) <- case boxity of-             Unboxed -> tcInferFRR (FRRUnboxedTuple i) (tcPolyExpr expr)+             Unboxed -> runInferRhoFRR (FRRUnboxedTuple i) (tcPolyExpr expr)              Boxed   -> do { arg_ty <- newFlexiTyVarTy liftedTypeKind                            ; L _ expr' <- tcCheckPolyExpr lexpr arg_ty                            ; return (expr', arg_ty) }@@ -1024,7 +1070,8 @@     tc_syn_arg _ (SynFun {}) _       = pprPanic "tcSynArgA hits a SynFun" (ppr orig)     tc_syn_arg res_ty (SynType the_ty) thing_inside-      = do { wrap   <- tcSubType orig GenSigCtxt res_ty the_ty+      = do { wrap   <- addSubTypeCtxt res_ty the_ty $+                       tcSubType orig GenSigCtxt Nothing res_ty the_ty            ; result <- thing_inside []            ; return (result, wrap) } @@ -1153,13 +1200,34 @@  Note [Type-directed record disambiguation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC currently supports an additional type-directed disambiguation-mechanism, which is deprecated and scheduled for removal as part of-GHC proposal #366 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst.+Deprecation notice:+  The type-directed disambiguation mechanism for record updates described in+  this Note is deprecated, as per GHC proposal #366 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst).+  The removal of type-directed disambiguation for record updates is tracked+  in GHC ticket #19461, but progress towards this goal has stalled. -To perform this disambiguation, when there are multiple possible parents for-a record update, the renamer defers to the typechecker.-See GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary+  Why? There are several suggested replacement mechanisms, such as:+    1. using module qualification to disambiguate,+    2. using OverloadedRecordUpdate for type-directed disambiguation+      (as described in Note [Overview of record dot syntax] in GHC.Hs.Expr).+  However, these solutions do not work in all situations:+    1. Module qualification doesn't work for fields defined in the current module,+       nor to disambiguate between constructors of different data family instances+       of a given parent data family TyCon.+    2. OverloadedRecordUpdate does not allow for type-changing record update,+       nor can it deal with fields with existentials or polytypes.+  There are also some avenues to improve the renamer's ability to disambiguate:+    - GHC ticket #23032 suggests using as-patterns to disambiguate in the renamer.+    - GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/537+      suggests a syntactic form of type-directed disambiguation that could be+      carried out in the renamer.+  Neither of these have been accepted/implemented at the time of writing (Sept 2025).+  This means that removal of type-directed disambiguation is currently stalled.++GHC tries to disambiguate record updates in the renamer, as described in+Note [Disambiguating record updates] in GHC.Rename.Pat. However, if the renamer+is unable to disambiguate, the renamer will defer to the typechecker: see+GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary function identifyParentLabels, which picks a parent for the record update using the following additional mechanisms: @@ -1255,7 +1323,7 @@                            -- Expanded record update expression                         , TcType                            -- result type of expanded record update-                        , SDoc+                        , ErrCtxtMsg                            -- error context to push when typechecking                            -- the expanded code                         )@@ -1300,8 +1368,11 @@            <- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty        ; let sel_ids       = map (unLoc . foLabel . unLoc . hfbLHS . unLoc) rbinds              upd_fld_names = map idName sel_ids-             relevant_cons = nonDetEltsUniqSet cons-             relevant_con  = head relevant_cons+             relevant_cons@(relevant_con NE.:| _) =+              case NE.nonEmpty $ nonDetEltsUniqSet cons of+                Just rel_cons -> rel_cons+                Nothing -> pprPanic "desugarRecordUpd: no relevant constructors" $+                              vcat [ text "record_expr:" <+> ppr record_expr ]        -- STEP 2: expand the record update.       --@@ -1427,7 +1498,7 @@              case_expr = HsCase RecUpd record_expr                        $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches)              matches :: [LMatch GhcRn (LHsExpr GhcRn)]-             matches = map make_pat relevant_cons+             matches = map make_pat (NE.toList relevant_cons)               let_binds :: HsLocalBindsLR GhcRn GhcRn              let_binds = HsValBinds noAnn $ XValBindsLR@@ -1446,31 +1517,12 @@             vcat [ text "relevant_con:" <+> ppr relevant_con                  , text "res_ty:" <+> ppr res_ty                  , text "ds_res_ty:" <+> ppr ds_res_ty+                 , text "ds_expr:" <+> ppr ds_expr                  ] -        ; let cons = pprQuotedList relevant_cons-              err_lines =-                (text "In a record update at field" <> plural upd_fld_names <+> pprQuotedList upd_fld_names :)-                $ case relevant_con of-                     RealDataCon con ->-                        [ text "with type constructor" <+> quotes (ppr (dataConTyCon con))-                        , text "data constructor" <+> plural relevant_cons <+> cons ]-                     PatSynCon {} ->-                        [ text "with pattern synonym" <+> plural relevant_cons <+> cons ]-                ++ if null ex_tvs-                   then []-                   else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ]-              err_ctxt = make_lines_msg err_lines+        ; return (ds_expr, ds_res_ty, RecordUpdCtxt relevant_cons upd_fld_names ex_tvs) } -        ; return (ds_expr, ds_res_ty, err_ctxt) } --- | Pretty-print a collection of lines, adding commas at the end of each line,--- and adding "and" to the start of the last line.-make_lines_msg :: [SDoc] -> SDoc-make_lines_msg []      = empty-make_lines_msg [last]  = ppr last <> dot-make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot-make_lines_msg (l:ls)  = l <> comma $$ make_lines_msg ls  {- ********************************************************************* *                                                                      *@@ -1568,7 +1620,8 @@     lookup_parent_flds par@(RnRecUpdParent { rnRecUpdLabels = lbls, rnRecUpdCons = cons })       = do { let cons' :: NonDetUniqFM ConLike ConLikeName                  cons' = NonDetUniqFM $ unsafeCastUFMKey $ getUniqSet cons-           ; cons <- traverse (tcLookupConLike . conLikeName_Name) cons'+                 lookup_one con = tcLookupConLike (noUserRdr $ getName con)+           ; cons <- traverse lookup_one cons'            ; tc   <- tcLookupRecSelParent par            ; return $                TcRecUpdParent@@ -1634,16 +1687,16 @@  tcRecordBinds         :: ConLike-        -> [TcType]     -- Expected type for each field+        -> [Scaled TcType]     -- Expected type for each field         -> HsRecordBinds GhcRn         -> TcM (HsRecordBinds GhcTc) -tcRecordBinds con_like arg_tys (HsRecFields _ rbinds dd)+tcRecordBinds con_like arg_tys (HsRecFields x rbinds dd)   = do  { mb_binds <- mapM do_bind rbinds-        ; return (HsRecFields [] (catMaybes mb_binds) dd) }+        ; return (HsRecFields x (catMaybes mb_binds) dd) }   where     fields = map flSelector $ conLikeFieldLabels con_like-    flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys+    flds_w_tys = zipEqual fields arg_tys      do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)             -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))@@ -1659,22 +1712,18 @@                                                      , hfbRHS = rhs'                                                      , hfbPun = hfbPun fld}))) } -fieldCtxt :: FieldLabelString -> SDoc-fieldCtxt field_name-  = text "In the" <+> quotes (ppr field_name) <+> text "field of a record"--tcRecordField :: ConLike -> Assoc Name Type+tcRecordField :: ConLike -> Assoc Name (Scaled Type)               -> LFieldOcc GhcRn -> LHsExpr GhcRn               -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) tcRecordField con_like flds_w_tys (L loc (FieldOcc rdr (L l sel_name))) rhs-  | Just field_ty <- assocMaybe flds_w_tys sel_name-      = addErrCtxt (fieldCtxt field_lbl) $-        do { rhs' <- tcCheckPolyExprNC rhs field_ty+  | Just (Scaled field_mult field_ty) <- assocMaybe flds_w_tys sel_name+      = addErrCtxt (FieldCtxt field_lbl)$+        do { rhs' <- tcScalingUsage field_mult $ tcCheckPolyExprNC rhs field_ty            ; hasFixedRuntimeRep_syntactic (FRRRecordCon rdr (unLoc rhs'))                 field_ty            ; let field_id = mkUserLocal (nameOccName sel_name)                                         (nameUnique sel_name)-                                        ManyTy field_ty (locA loc)+                                        field_mult field_ty (locA loc)                 -- Yuk: the field_id has the *unique* of the selector Id                 --          (so we can find it easily)                 --      but is a LocalId with the appropriate type of the RHS
compiler/GHC/Tc/Gen/Expr.hs-boot view
@@ -1,8 +1,8 @@ module GHC.Tc.Gen.Expr where import GHC.Hs              ( HsExpr, LHsExpr, SyntaxExprRn                            , SyntaxExprTc )-import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR-                           , SyntaxOpType+import GHC.Tc.Utils.TcType ( TcType, TcRhoType, TcSigmaType, TcSigmaTypeFRR+                           , SyntaxOpType, InferInstFlag                            , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types        ( TcM ) import GHC.Tc.Types.BasicTypes( TcCompleteSig )@@ -32,6 +32,8 @@  tcInferRho, tcInferRhoNC ::           LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)++tcInferExpr :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)  tcSyntaxOp :: CtOrigin            -> SyntaxExprRn
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -254,7 +254,7 @@           -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty                                     , fd_fi = imp_decl }))-  = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo)  $+  = setSrcSpanA dloc $ addErrCtxt (ForeignDeclCtxt fo)  $     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty        ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty        ; let@@ -412,7 +412,7 @@ tcFExport :: ForeignDecl GhcRn           -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt) tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })-  = addErrCtxt (foreignDeclCtxt fo) $ do+  = addErrCtxt (ForeignDeclCtxt fo) $ do      sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty     rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty@@ -579,12 +579,6 @@       -> TcM () check IsValid _                   = return () check (NotValid reason) mkMessage = addErrTc (mkMessage reason)--foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc-foreignDeclCtxt fo-  = hang (text "When checking declaration:")-       2 (ppr fo)-  {- Predicates on Types used in this module -} 
compiler/GHC/Tc/Gen/Head.hs view
@@ -23,8 +23,8 @@        , leadingValArgs, isVisibleArg         , tcInferAppHead, tcInferAppHead_maybe-       , tcInferId, tcCheckId, obviousSig-       , tyConOf, tyConOfET, fieldNotInType+       , tcInferId, tcCheckId, tcInferConLike, obviousSig+       , tyConOf, tyConOfET        , nonBidirectionalErr         , pprArgInst@@ -58,7 +58,7 @@  import GHC.Core.FamInstEnv    ( FamInstEnvs ) import GHC.Core.UsageEnv      ( singleUsageUE, UsageEnv )-import GHC.Core.PatSyn( PatSyn )+import GHC.Core.PatSyn( PatSyn, patSynName ) import GHC.Core.ConLike( ConLike(..) ) import GHC.Core.DataCon import GHC.Core.TyCon@@ -66,7 +66,6 @@ import GHC.Core.Type  import GHC.Types.Id-import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SrcLoc@@ -75,7 +74,6 @@  import GHC.Builtin.Types( multiplicityTy ) import GHC.Builtin.Names-import GHC.Builtin.Names.TH( liftStringName, liftName )  import GHC.Driver.DynFlags import GHC.Utils.Misc@@ -83,8 +81,6 @@ import GHC.Utils.Panic  import GHC.Data.Maybe-import Control.Monad-import GHC.Rename.Unbound (WhatLooking(WL_Anything))   @@ -324,6 +320,7 @@         ctxt' = case splice of             HsUntypedSpliceExpr _ (L l _) -> set l ctxt -- l :: SrcAnn AnnListItem             HsQuasiQuote _ _ (L l _)      -> set l ctxt -- l :: SrcAnn NoEpAnns+            (XUntypedSplice (HsImplicitLiftSplice _ _ _ (L l _))) -> set l ctxt      -- See Note [Looking through ExpandedThingRn]     go (XExpr (ExpandedThingRn o e)) ctxt args@@ -559,7 +556,7 @@     do { mb_tc_fun <- tcInferAppHead_maybe fun        ; case mb_tc_fun of             Just (fun', fun_sigma) -> return (fun', fun_sigma)-            Nothing -> tcInfer (tcExpr fun) }+            Nothing -> runInferRho (tcExpr fun) }  tcInferAppHead_maybe :: HsExpr GhcRn                      -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))@@ -567,7 +564,7 @@ -- Returns Nothing for a complicated head tcInferAppHead_maybe fun   = case fun of-      HsVar _ (L _ nm)          -> Just <$> tcInferId nm+      HsVar _ nm                -> Just <$> tcInferId nm       XExpr (HsRecSelRn f)      -> Just <$> tcInferRecSelId f       ExprWithTySig _ e hs_ty   -> Just <$> tcExprWithSig e hs_ty       HsOverLit _ lit           -> Just <$> tcInferOverLit lit@@ -652,12 +649,6 @@ tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 -fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage-fieldNotInType p rdr-  = mkTcRnNotInScope rdr $-    UnknownSubordinate (text "field of type" <+> quotes (ppr p))-- {- ********************************************************************* *                                                                      *                 Expressions with a type signature@@ -697,7 +688,8 @@                         | otherwise                         = NoRestrictions        ; ((qtvs, givens, ev_binds, _), residual)-           <- captureConstraints $ simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+           <- captureConstraints $+              simplifyInfer NotTopLevel tclvl infer_mode [sig_inst] [(name, tau)] wanted        ; emitConstraints residual         ; tau <- liftZonkM $ zonkTcType tau@@ -764,6 +756,8 @@     --   where fromInteger is gotten by looking up from_name, and     --   the (3 :: Integer) is returned by mkOverLit     -- Ditto the string literal "foo" to (fromString ("foo" :: String))+    --+    -- See Note [Typechecking overloaded literals] in GHC.Tc.Gen.Expr     do { hs_lit <- mkOverLit val        ; from_id <- tcLookupId from_name        ; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id)@@ -778,11 +772,12 @@        ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $                         HsLit noExtField hs_lit              from_expr = mkHsWrap (wrap2 <.> wrap1) $-                         HsVar noExtField (L loc from_id)+                         mkHsVar (L loc from_id)              witness = HsApp noExtField (L (l2l loc) from_expr) lit_expr-             lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable-                                             , ol_witness = witness-                                             , ol_type = res_ty } }+             lit' = OverLit { ol_val = val+                            , ol_ext = OverLitTc { ol_rebindable = rebindable+                                                 , ol_witness = witness+                                                 , ol_type = res_ty } }        ; return (HsOverLit noExtField lit', res_ty) }  {- *********************************************************************@@ -793,43 +788,33 @@  tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc) tcCheckId name res_ty-  = do { (expr, actual_res_ty) <- tcInferId name+  = do { (expr, actual_res_ty) <- tcInferId (noLocA $ noUserRdr name)        ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])        ; addFunResCtxt expr [] actual_res_ty res_ty $          tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }   where-    rn_fun = HsVar noExtField (noLocA name)+    rn_fun = mkHsVar (noLocA name)  -------------------------tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)+tcInferId :: LocatedN (WithUserRdr Name) -> TcM (HsExpr GhcTc, TcSigmaType) -- Look up an occurrence of an Id -- Do not instantiate its type-tcInferId id_name+tcInferId lname@(L loc (WithUserRdr rdr id_name))+   | id_name `hasKey` assertIdKey-  = do { dflags <- getDynFlags+  = -- See Note [Overview of assertions]+    do { dflags <- getDynFlags        ; if gopt Opt_IgnoreAsserts dflags-         then tc_infer_id id_name-         else tc_infer_assert id_name }+         then tc_infer_id lname+         else tc_infer_id (L loc $ WithUserRdr rdr assertErrorName) }    | otherwise-  = do { (expr, ty) <- tc_infer_id id_name-       ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)-       ; return (expr, ty) }--tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)--- Deal with an occurrence of 'assert'--- See Note [Adding the implicit parameter to 'assert']-tc_infer_assert assert_name-  = do { assert_error_id <- tcLookupId assertErrorName-       ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)-                                          (idType assert_error_id)-       ; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho)-       }+  = tc_infer_id lname -tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)-tc_infer_id id_name+tc_infer_id :: LocatedN (WithUserRdr Name) -> TcM (HsExpr GhcTc, TcSigmaType)+tc_infer_id (L loc (WithUserRdr rdr id_name))  = do { thing <- tcLookup id_name-      ; case thing of+      ; (expr,ty) <- case thing of              ATcId { tct_id = id }                -> do { check_local_id id                      ; return_id id }@@ -839,17 +824,50 @@                -- nor does it need the 'lifting' treatment                -- Hence no checkTh stuff here -             AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con-             AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps-             (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything (tyConName tc)-             ATyVar name _ -> failIllegalTyVal name+             AGlobal (AConLike cl) -> tcInferConLike cl -             _ -> failWithTc $ TcRnExpectedValueId thing }+             (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Term (WithUserRdr rdr (tyConName tc))+             ATyVar name _ -> failIllegalTyVar (WithUserRdr rdr name)++             _ -> failWithTc $ TcRnExpectedValueId thing++       ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)+       ; return (expr, ty) }   where-    return_id id = return (HsVar noExtField (noLocA id), idType id)+    return_id id = return (mkHsVar (L loc id), idType id) -{- Note [Suppress hints with RequiredTypeArguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Overview of assertions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you write (assert pred x) then++  * If `-fignore-asserts` (which sets Opt_IgnoreAsserts) is on, the code is+    typechecked as written, but `assert`, defined in GHC.Internal.Base+       assert _pred r = r+    simply ignores `pred`++  * But without `-fignore-asserts`, GHC rewrites it to (assertError pred e)+    and that is defined in GHC.Internal.IO.Exception as+        assertError :: (?callStack :: CallStack) => Bool -> a -> a+    which does test the predicate and, if it is not True, throws an exception,+    capturing the CallStack.++    This rewrite is done in `tcInferId`.++So `-fignore-asserts` makes the assertion go away altogether, which may be good for+production code.++The reason that `assert` and `assertError` are defined in very different modules+is a historical accident.++Note: the Haddock for `assert` is on `GHC.Internal.Base.assert`, since that is+what appears in the user's source proram.++It's not entirely kosher to rewrite `assert` to `assertError`, because there's no+way to "undo" if you want to see the original source code in the typechecker+output.  We can fix this if it becomes a problem.++Note [Suppress hints with RequiredTypeArguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When a type variable is used at the term level, GHC assumes the user might have made a typo and suggests a term variable with a similar name. @@ -895,14 +913,17 @@  check_local_id :: Id -> TcM () check_local_id id-  = do { checkThLocalId id-       ; tcEmitBindingUsage $ singleUsageUE id }+  = do { tcEmitBindingUsage $ singleUsageUE id }  check_naughty :: OccName -> TcId -> TcM () check_naughty lbl id   | isNaughtyRecordSelector id = failWithTc (TcRnRecSelectorEscapedTyVar lbl)   | otherwise                  = return () +tcInferConLike :: ConLike -> TcM (HsExpr GhcTc, TcSigmaType)+tcInferConLike (RealDataCon con) = tcInferDataCon con+tcInferConLike (PatSynCon ps)    = tcInferPatSyn  ps+ tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType) -- See Note [Typechecking data constructors] tcInferDataCon con@@ -924,7 +945,7 @@                 -- in GHC.Core.DataCon.         ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)-                , mkInvisForAllTys tvbs $ mkPhiTy full_theta $+                , mkForAllTys tvbs $ mkPhiTy full_theta $                   mkScaledFunTys scaled_arg_tys res ) }   where     linear_to_poly :: Scaled Type -> TcM (Scaled Type)@@ -934,25 +955,17 @@                                           ; return (Scaled mul_var ty) }     linear_to_poly scaled_ty         = return scaled_ty -tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)-tcInferPatSyn id_name ps+tcInferPatSyn :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)+tcInferPatSyn ps   = case patSynBuilderOcc ps of        Just (expr,ty) -> return (expr,ty)-       Nothing        -> failWithTc (nonBidirectionalErr id_name)+       Nothing        -> failWithTc (nonBidirectionalErr (patSynName ps))  nonBidirectionalErr :: Name -> TcRnMessage nonBidirectionalErr = TcRnPatSynNotBidirectional -{- Note [Adding the implicit parameter to 'assert']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The typechecker transforms (assert e1 e2) to (assertError e1 e2).-This isn't really the Right Thing because there's no way to "undo"-if you want to see the original source code in the typechecker-output.  We'll have fix this in due course, when we care more about-being able to reconstruct the exact original program.--Note [Typechecking data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- 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:@@ -1054,81 +1067,7 @@ ************************************************************************ -} -checkThLocalId :: Id -> TcM ()--- The renamer has already done checkWellStaged,---   in RnSplice.checkThLocalName, so don't repeat that here.--- Here we just add constraints for cross-stage lifting-checkThLocalId id-  = do  { mb_local_use <- getStageAndBindLevel (idName id)-        ; case mb_local_use of-             Just (top_lvl, bind_lvl, use_stage)-                | thLevel use_stage > bind_lvl-                -> checkCrossStageLifting top_lvl id use_stage-             _  -> return ()   -- Not a locally-bound thing, or-                               -- no cross-stage link-    } ----------------------------------------checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()--- If we are inside typed brackets, and (use_lvl > bind_lvl)--- we must check whether there's a cross-stage lift to do--- Examples   \x -> [|| x ||]---            [|| map ||]------ This is similar to checkCrossStageLifting in GHC.Rename.Splice, but--- this code is applied to *typed* brackets.--checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))-  | isTopLevel top_lvl-  = when (isExternalName id_name) (keepAlive id_name)-    -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice--  | otherwise-  =     -- Nested identifiers, such as 'x' in-        -- E.g. \x -> [|| h x ||]-        -- We must behave as if the reference to x was-        --      h $(lift x)-        -- We use 'x' itself as the splice proxy, used by-        -- the desugarer to stitch it all back together.-        -- If 'x' occurs many times we may get many identical-        -- bindings of the same splice proxy, but that doesn't-        -- matter, although it's a mite untidy.-    do  { let id_ty = idType id-        ; checkTc (isTauTy id_ty) $-          TcRnTHError $ TypedTHError $ SplicePolymorphicLocalVar id-               -- If x is polymorphic, its occurrence sites might-               -- have different instantiations, so we can't use plain-               -- 'x' as the splice proxy name.  I don't know how to-               -- solve this, and it's probably unimportant, so I'm-               -- just going to flag an error for now--        ; lift <- if isStringTy id_ty then-                     do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName-                                     -- See Note [Lifting strings]-                        ; return (HsVar noExtField (noLocA sid)) }-                  else-                     setConstraintVar lie_var   $-                          -- Put the 'lift' constraint into the right LIE-                     newMethodFromName (OccurrenceOf id_name)-                                       GHC.Builtin.Names.TH.liftName-                                       [getRuntimeRep id_ty, id_ty]--                   -- Warning for implicit lift (#17804)-        ; addDetailedDiagnostic (TcRnImplicitLift $ idName id)--                   -- Update the pending splices-        ; ps <- readMutVar ps_var-        ; let pending_splice = PendingTcSplice id_name-                                 (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift))-                                          (nlHsVar id))-        ; writeMutVar ps_var (pending_splice : ps)--        ; return () }-  where-    id_name = idName id--checkCrossStageLifting _ _ _ = return ()- {- Note [Lifting strings] ~~~~~~~~~~~~~~~~~~~~~~@@ -1147,6 +1086,35 @@ Record selectors for TyCons in this module are ordinary local bindings, which show up as ATcIds rather than AGlobals.  So we need to check for naughtiness in both branches.  c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds.++Note [Explicit Level Imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This is the overview note which explains the whole implementation of ExplicitLevelImports++GHC Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0682-explicit-level-imports.rst+Paper: https://mpickering.github.io/papers/explicit-level-imports.pdf++The feature is turned on by the `ExplicitLevelImports` extension.+At the source level, the user marks imports with `quote` or `splice` to introduce+them at level 1 or -1.++The function GHC.Tc.Utils.Monad.getCurrentAndBindLevel. computes the levels+at which a Name is available:+  - for top-level Names, this information is stored in its GRE; it is either local+    (level 0) or imported, in which case the levels it is imported at are stored in the+    'ImpDeclSpec's for the GRE. The function 'greLevels' retrieves this information.+  - for locally-bound Names, this information is stored in the ThBindEnv.+GHC.Rename.Splice.checkCrossLevelLifting checks that levels in user-written programs+are correct.++Instances are checked by `checkWellLevelledDFun`, which computes the level of an+instance by calling `checkWellLevelledInstanceWhat`, which sees what is available at by looking at the module graph.++That's it for the main implementation of the feature; the rest is modifications+to the driver parts of the code to use this information. For example, in downsweep,+we only enable code generation for modules needed at the runtime stage.+See Note [-fno-code mode].+ -}  @@ -1186,37 +1154,11 @@                      -- is not deeply skolemised, so still use tcSplitNestedSigmaTys                  (args_fun, res_fun) = tcSplitFunTys fun_tau                  (args_env, res_env) = tcSplitFunTys env_tau-                 n_fun = length args_fun-                 n_env = length args_env-                 info  | -- Check for too few args-                         --  fun_tau = a -> b, res_tau = Int-                         n_fun > n_env-                       , not_fun res_env-                       = text "Probable cause:" <+> quotes (ppr fun)-                         <+> text "is applied to too few arguments"--                       | -- Check for too many args-                         -- fun_tau = a -> Int,   res_tau = a -> b -> c -> d-                         -- The final guard suppresses the message when there-                         -- aren't enough args to drop; eg. the call is (f e1)-                         n_fun < n_env-                       , not_fun res_fun-                       , (n_fun + count isValArg args) >= n_env-                          -- Never suggest that a naked variable is-                                           -- applied to too many args!-                       = text "Possible cause:" <+> quotes (ppr fun)-                         <+> text "is applied to too many arguments"--                       | otherwise-                       = Outputable.empty-+                 info =+                  FunResCtxt fun (count isValArg args) res_fun res_env+                    (length args_fun) (length args_env)            ; return info } -    not_fun ty   -- ty is definitely not an arrow type,-                 -- and cannot conceivably become one-      = case tcSplitTyConApp_maybe ty of-          Just (tc, _) -> isAlgTyCon tc-          Nothing      -> False  {- Note [Splitting nested sigma types in mismatched function types]@@ -1268,25 +1210,15 @@ ********************************************************************* -}  addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a-addStmtCtxt stmt thing_inside-  = do let err_doc = pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) stmt-       addErrCtxt err_doc thing_inside-  where-    pprStmtInCtxt :: HsStmtContextRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc-    pprStmtInCtxt ctxt stmt-      = vcat [ hang (text "In a stmt of"-                     <+> pprAStmtContext ctxt <> colon) 2 (pprStmt stmt)-             ]+addStmtCtxt stmt =+  addErrCtxt (StmtErrCtxt (HsDoStmt (DoExpr Nothing)) stmt)  addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a addExprCtxt e thing_inside   = case e of-      HsUnboundVar {} -> thing_inside-      _ -> addErrCtxt (exprCtxt e) thing_inside-   -- The HsUnboundVar special case addresses situations like+      HsHole _ -> thing_inside+      _ -> addErrCtxt (ExprCtxt e) thing_inside+   -- The HsHole special case addresses situations like    --    f x = _    -- when we don't want to say "In the expression: _",    -- because it is mentioned in the error message itself--exprCtxt :: HsExpr GhcRn -> SDoc-exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))
compiler/GHC/Tc/Gen/HsType.hs view
@@ -7,8 +7,6 @@ {-# LANGUAGE ViewPatterns        #-} {-# LANGUAGE RecursiveDo        #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -25,7 +23,7 @@         funsSigCtxt, addSigCtxt, pprSigCtxt,          tcHsClsInstType,-        tcHsDefault, tcHsDeriv, tcDerivStrategy,+        tcDefaultDeclClass, tcHsDeriv, tcDerivStrategy,         tcHsTypeApp,         UserTypeCtxt(..),         bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,@@ -35,6 +33,7 @@          bindOuterFamEqnTKBndrs_Q_Tv, bindOuterFamEqnTKBndrs,         tcOuterTKBndrs, scopedSortOuter, outerTyVars, outerTyVarBndrs,+        tcGadtConTyVarBndrs,         bindOuterSigTKBndrs_Tv,         tcExplicitTKBndrs,         bindNamedWildCardBinders,@@ -42,7 +41,8 @@         -- Type checking type and class decls, and instances thereof         bindTyClTyVars, bindTyClTyVarsAndZonk,         tcFamTyPats,-        etaExpandAlgTyCon, tcbVisibilities,+        maybeEtaExpandAlgTyCon, tcbVisibilities,+        etaExpandAlgTyCon,            -- tyvars         zonkAndScopedSort,@@ -69,14 +69,12 @@         tcMult,          -- Pattern type signatures-        tcHsPatSigType, tcHsTyPat,+        tcHsPatSigType, tcHsTyPat, tcRuleBndrSig,         HoleMode(..), -        -- Error messages-        funAppCtxt, addTyConFlavCtxt,-         -- Utils         tyLitFromLit, tyLitFromOverloadedLit,+    ) where  import GHC.Prelude hiding ( head, init, last, tail )@@ -87,6 +85,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Tc.Types.LclEnv+import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType@@ -108,7 +107,7 @@ import GHC.Builtin.Types.Prim import GHC.Types.Error import GHC.Types.Name.Env-import GHC.Types.Name.Reader( lookupLocalRdrOcc )+import GHC.Types.Name.Reader( WithUserRdr(..), lookupLocalRdrOcc ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Core.TyCon@@ -358,11 +357,15 @@ funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC funsSigCtxt []              = panic "funSigCtxt" -addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a+addSigCtxt :: UserTypeCtxt -> UserSigType GhcRn -> TcM a -> TcM a addSigCtxt ctxt hs_ty thing_inside-  = setSrcSpan (getLocA hs_ty) $-    addErrCtxt (pprSigCtxt ctxt hs_ty) $+  = setSrcSpan l $+    addErrCtxt (UserSigCtxt ctxt hs_ty) $     thing_inside+  where+    l = case hs_ty of+      UserLHsSigType ty -> getLocA ty+      UserLHsType ty    -> getLocA ty  pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc -- (pprSigCtxt ctxt <extra> <type>)@@ -392,14 +395,14 @@ --     meth :: forall a (x :: f a). Proxy x -> () -- When instantiating Proxy with kappa, we must unify kappa := f a. But we're -- still working out the kind of f, and thus f a will have a coercion in it.--- Coercions may block unification (Note [Equalities with incompatible kinds] in+-- Coercions may block unification (Note [Equalities with heterogeneous kinds] in -- GHC.Tc.Solver.Equality, wrinkle (EIK2)) and so we fail to unify. If we try to -- kind-generalize, we'll end up promoting kappa to the top level (because -- kind-generalization is normally done right before adding a binding to the context), -- and then we can't set kappa := f a, because a is local. kcClassSigType names     sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty }))-  = addSigCtxt (funsSigCtxt names) sig_ty $+  = addSigCtxt (funsSigCtxt names) (UserLHsSigType sig_ty) $     do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs    $               tcCheckLHsType hs_ty liftedTypeKind        ; return () }@@ -407,7 +410,7 @@ tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking tcClassSigType names sig_ty-  = addSigCtxt sig_ctxt sig_ty $+  = addSigCtxt sig_ctxt (UserLHsSigType sig_ty) $     do { skol_info <- mkSkolemInfo skol_info_anon        ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind)        ; emitImplication implic@@ -436,7 +439,7 @@ -- Does validity checking -- See Note [Recipe for checking a signature] tcHsSigType ctxt sig_ty-  = addSigCtxt ctxt sig_ty $+  = addSigCtxt ctxt (UserLHsSigType sig_ty) $     do { traceTc "tcHsSigType {" (ppr sig_ty)        ; skol_info <- mkSkolemInfo skol_info           -- Generalise here: see Note [Kind generalisation]@@ -585,7 +588,7 @@ -- Does validity checking and zonking. tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))-  = addSigCtxt ctxt ksig $+  = addSigCtxt ctxt (UserLHsSigType ksig) $     do { kind <- tc_top_lhs_type KindLevel ctxt ksig        ; checkValidType ctxt kind        ; return (name, kind) }@@ -630,53 +633,79 @@   where     skol_info_anon = SigTypeSkol ctxt -tcClassConstraint :: Type -> TcM (Either (Maybe TyCon) ([TyVar], Class, [Type], [Kind]))--- Like tcHsSigType, but for a simple class constraint of form ( C ty1 ty2 )--- Returns the C, [ty1, ty2], and the kinds of C's remaining arguments--- E.g.    class C (a::*) (b::k->k)---         tcClassConstraint ( C Int ) returns Right ([k], C, [k, Int], [k->k])--- Return values are fully zonked-tcClassConstraint ty-  = do { let (tvs, pred)    = splitForAllTyCoVars ty-             (kind_args, _) = splitFunTys (typeKind pred)-      -- Checking that `pred` a is type class application-       ; case splitTyConApp_maybe pred of-          Just (tyCon, tyConArgs) ->-            case tyConClass_maybe tyCon of-              Just clas ->-                return (Right (tvs, clas, tyConArgs, map scaledThing kind_args))-              Nothing -> return (Left (Just tyCon))-          Nothing -> return (Left Nothing) }+-- | Typecheck the class in a default declaration, checking that:+--+--  - it is indeed a class (not e.g. a type family),+--  - that the class expects some invisible arguments followed+--    by a single visible argument.+tcDefaultDeclClass :: LIdP GhcRn -> TcM (Maybe Class)+tcDefaultDeclClass l_nm+  = setSrcSpan (locA l_nm) $+  do { let nm = unLoc l_nm+     ; thing <- tcLookupGlobal nm+     ; case thing of+        ATyCon tc+          | Just cls <- tyConClass_maybe tc+          -> if is_unary (tyConBinders tc)+             then return $ Just cls+             else+               do { addErrTc $ TcRnNonUnaryTypeclassConstraint DefaultDeclCtxt (NameThing nm)+                  ; return Nothing } -tcHsDefault :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])--- Like tcHsSigType, but for the default ( C ty1 ty2 ) (ty1', ty2', ...) declaration--- See Note [Named default declarations] in GHC.Tc.Gen.Default-tcHsDefault hs_ty-  = tcTopLHsType DefaultDeclCtxt hs_ty-    >>= tcClassConstraint-    >>= either (const $ failWithTc $ TcRnIllegalDefaultClass hs_ty) return+        _ -> do { addErrTc $ TcRnIllegalDefaultClass nm+                ; return Nothing }+     }+  where+    is_unary :: [TyConBinder] -> Bool+    is_unary = ( `lengthIs` 1 ) . dropWhile isInvisibleTyConBinder  ------------------tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])--- Like tcHsSigType, but for the ...deriving( C ty1 ty2 ) clause--- Returns the C, [ty1, ty2], and the kinds of C's remaining arguments--- E.g.    class C (a::*) (b::k->k)---         data T a b = ... deriving( C Int )---    returns ([k], C, [k, Int], [k->k])+tcHsDeriv :: LHsSigType GhcRn -> TcM (Maybe (Class, [TyCoVar], [Type], Kind))+-- ^ Like tcHsSigType, but for the @...deriving( C ty1 ty2 )@ clause+--+-- Returns a class constraint with the last argument missing, and the+-- expected kind of the remaining argument.+--+-- E.g.:+--+--  @class C (a::*) (b::k->k)@+--  @data T a b = ... deriving( C Int )@+--+-- This function returns @(C, [k], [k, Int], k->k)@.+-- -- Return values are fully zonked tcHsDeriv hs_ty   = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty-       ; constrained <- tcClassConstraint ty-       ; case constrained of-           Left Nothing -> failWithTc (TcRnIllegalDerivingItem hs_ty)-           Left (Just tyCon) ->-             failWithTc $ TcRnIllegalInstance-                        $ IllegalClassInstance (TypeThing ty)-                        $ IllegalInstanceHead-                        $ InstHeadNonClass-                        $ Just tyCon-           Right result -> return result } +       ; let (tvs, pred)    = splitForAllTyCoVars ty+             (kind_args, _) = splitFunTys (typeKind pred)+      -- Checking that `pred` a is type class application++       ; case splitTyConApp_maybe pred of+            Just (tc, tc_args) ->+              case tyConClass_maybe tc of+                Just cls ->+                  case kind_args of+                    [Scaled _ last_kind] ->+                      return $ Just $+                        (cls, tvs, tc_args, last_kind)+                    _ ->+                      do { addErrTc $ TcRnNonUnaryTypeclassConstraint DerivClauseCtxt (TypeThing pred)+                         ; return Nothing+                         }+                Nothing ->+                  do { addErrTc $ TcRnIllegalInstance+                                $ IllegalClassInstance (TypeThing ty)+                                $ IllegalInstanceHead+                                $ InstHeadNonClassHead+                                $ InstNonClassTyCon+                                    (noUserRdr $ tyConName tc)+                                    (fmap tyConName $ tyConFlavour tc)+                     ; return Nothing }+            Nothing ->+              do { addErrTc $ TcRnIllegalDerivingItem hs_ty; return Nothing }+       }+ -- | Typecheck a deriving strategy. For most deriving strategies, this is a -- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. tcDerivStrategy :: Maybe (LDerivStrategy GhcRn)@@ -801,7 +830,7 @@   where     fam_name  = tyConName fam_tc     fam_arity = tyConArity fam_tc-    lhs_fun   = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name))+    lhs_fun   = noLocA (HsTyVar noAnn NotPromoted (noLocA $ noUserRdr fam_name))  {- Note [tcFamTyPats: zonking the result kind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -917,7 +946,7 @@  then `id` gets instantiated to have type alpha -> alpha. The variable alpha is then unconstrained and regeneralized. So we may well end up with-  x = /\x. id @a+  x = /\a. id @a But we cannot do this in types, as we have no type-level lambda.  So, we must be careful only to instantiate at the last possible moment, when@@ -925,9 +954,15 @@ in calls to `tcInstInvisibleTyBinders`; a particular case in point is in `checkExpectedKind`. +For example, suppose we have:+    Actual:  ∀ k2 k. k -> k2   -> k+  Expected:  ∀    k. k -> Type -> k+We must very delicately instantiate just k2 to kappa, and then unify+  (∀ k. k -> Type -> k) ~ (∀ k. k -> kappa -> k)+ Otherwise, we are careful /not/ to instantiate.  For example:-* at a variable  in `tcTyVar`-* in `tcInferLHsTypeUnsaturated`, which is used by :kind in GHCi.+  * at a variable  in `tcTyVar`+  * in `tcInferLHsTypeUnsaturated`, which is used by :kind in GHCi.  ************************************************************************ *                                                                      *@@ -943,8 +978,8 @@  -} -tcMult :: HsArrow GhcRn -> TcM Mult-tcMult hc = tc_mult typeLevelMode hc+tcMult :: LHsType GhcRn -> TcM Mult+tcMult ty = tc_check_lhs_type typeLevelMode ty multiplicityTy  -- | Info about the context in which we're checking a type. Currently, -- differentiates only between types and kinds, but this will likely@@ -1028,9 +1063,9 @@ -- | Infer the kind of a type and desugar. This is the "up" type-checker, -- as described in Note [Bidirectional type checking] tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)- tc_infer_hs_type mode rn_ty-  = tcInfer $ \exp_kind -> tcHsType mode rn_ty exp_kind+  = runInferKind $ \exp_kind ->+    tcHsType mode rn_ty exp_kind  {- Note [Typechecking HsCoreTys]@@ -1098,15 +1133,6 @@  tcHsType mode (HsParTy _ ty)   exp_kind = tcLHsType mode ty exp_kind tcHsType mode (HsDocTy _ ty _) exp_kind = tcLHsType mode ty exp_kind-tcHsType _ ty@(HsBangTy _ bang _) _-    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),-    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of-    -- bangs are invalid, so fail. (#7210, #14761)-    = failWith $ TcRnUnexpectedAnnotation ty bang-tcHsType _ ty@(HsRecTy {})      _-      -- Record types (which only show up temporarily in constructor-      -- signatures) should have been removed by now-    = failWithTc $ TcRnIllegalRecordSyntax (Right ty)  -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. -- Here we get rid of it and add the finalizers to the global environment@@ -1124,9 +1150,9 @@ tcHsType mode (HsFunTy _ mult ty1 ty2) exp_kind   = tc_fun_type mode mult ty1 ty2 exp_kind -tcHsType mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind+tcHsType mode (HsOpTy _ _ ty1 (L _ (WithUserRdr _ op)) ty2) exp_kind   | op `hasKey` unrestrictedFunTyConKey-  = tc_fun_type mode (HsUnrestrictedArrow noExtField) ty1 ty2 exp_kind+  = tc_fun_type mode (HsUnannotated noExtField) ty1 ty2 exp_kind  --------- Foralls tcHsType mode t@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind@@ -1369,10 +1395,7 @@ -}  -------------------------------------------tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult-tc_mult mode ty = tc_check_lhs_type mode (arrowToHsType ty) multiplicityTy--------------------------------------------tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> ExpKind+tc_fun_type :: TcTyMode -> HsMultAnn GhcRn -> LHsType GhcRn -> LHsType GhcRn -> ExpKind             -> TcM TcType tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of   TypeLevel ->@@ -1392,6 +1415,10 @@        ; checkExpKind (HsFunTy noExtField mult ty1 ty2)                       (tcMkVisFunTy mult' ty1' ty2')                       liftedTypeKind exp_kind }+  where+    tc_mult mode mult = case multAnnToHsType mult of+      Just mult' -> tc_check_lhs_type mode mult' multiplicityTy+      Nothing    -> return manyDataConTy  {- Note [Skolem escape and forall-types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1460,15 +1487,10 @@ finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do   traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)   case tup_sort of-    ConstraintTuple-      |  [tau_ty] <- tau_tys-         -- Drop any uses of 1-tuple constraints here.-         -- See Note [Ignore unary constraint tuples]-      -> check_expected_kind tau_ty constraintKind-      |  otherwise-      -> do let tycon = cTupleTyCon arity-            checkCTupSize arity-            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind+    ConstraintTuple -> do+      let tycon = cTupleTyCon arity+      checkCTupSize arity+      check_expected_kind (mkTyConApp tycon tau_tys) constraintKind     BoxedTuple -> do       let tycon = tupleTyCon Boxed arity       checkTupSize arity@@ -1487,47 +1509,6 @@     check_expected_kind ty act_kind =       checkExpectedKind rn_ty ty act_kind exp_kind -{--Note [Ignore unary constraint tuples]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in-GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First,-recall the definition of a unary tuple data type:--  data Solo a = Solo a--Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and-lazy. Therefore, the presence of `Solo` matters semantically. On the other-hand, suppose we had a unary constraint tuple:--  class a => Solo% a--This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is-semantically equivalent to `a`. Therefore, a 1-tuple constraint would have-no user-visible impact, nor would it allow you to express anything that-you couldn't otherwise.--We could simply add Solo% for consistency with tuples (Solo) and unboxed-tuples (Solo#), but that would require even more magic to wire in another-magical class, so we opt not to do so. We must be careful, however, since-one can try to sneak in uses of unary constraint tuples through Template-Haskell, such as in this program (from #17511):--  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]-                       (ConT ''String)))-  -- f :: Solo% (Show Int) => String-  f = "abc"--This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,-and since it is used in a Constraint position, GHC will attempt to treat-it as thought it were a constraint tuple, which can potentially lead to-trouble if one attempts to look up the name of a constraint tuple of arity-1 (as it won't exist). To avoid this trouble, we simply take any unary-constraint tuples discovered when typechecking and drop them—i.e., treat-"Solo% a" as though the user had written "a". This is always safe to do-since the two constraints should be semantically equivalent.--}- {- ********************************************************************* *                                                                      *                 Type applications@@ -1542,7 +1523,8 @@     is_app :: HsType GhcRn -> Bool     is_app (HsAppKindTy {})        = True     is_app (HsAppTy {})            = True-    is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` unrestrictedFunTyConKey)+    is_app (HsOpTy _ _ _ (L _ (WithUserRdr _ op)) _)+      = not (op `hasKey` unrestrictedFunTyConKey)       -- I'm not sure why this funTyConKey test is necessary       -- Can it even happen?  Perhaps for   t1 `(->)` t2       -- but then maybe it's ok to treat that like a normal@@ -1573,7 +1555,7 @@ -- application. In particular, for a HsTyVar (which includes type -- constructors, it does not zoom off into tcInferTyApps and family -- saturation-tcInferTyAppHead _ (L _ (HsTyVar _ _ (L _ tv)))+tcInferTyAppHead _ (L _ (HsTyVar _ _ (L _ (WithUserRdr _ tv))))   = tcTyVar tv tcInferTyAppHead mode ty   = tc_infer_lhs_type mode ty@@ -1671,7 +1653,7 @@              ; let exp_kind = substTy subst $ piTyBinderType ki_binder              ; arg_mode <- mkHoleMode KindLevel HM_VTA                    -- HM_VKA: see Note [Wildcards in visible kind application]-             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $+             ; ki_arg <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty hs_ki_arg) n) $                          tc_check_lhs_type arg_mode hs_ki_arg exp_kind               ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)@@ -1702,7 +1684,7 @@                                 , ppr (piTyBinderType ki_binder)                                 , ppr subst ])                 ; let exp_kind = substTy subst $ piTyBinderType ki_binder-                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $+                ; arg' <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty arg) n) $                           tc_check_lhs_type mode arg exp_kind                 ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)                 ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'@@ -1984,11 +1966,11 @@                 ; return (res_ty `mkCastTy` co_k) } }     where       -- We need to make sure that both kinds have the same number of implicit-      -- foralls out front. If the actual kind has more, instantiate accordingly.-      -- Otherwise, just pass the type & kind through: the errors are caught-      -- in unifyType.-      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind-      n_act_invis_bndrs = invisibleTyBndrCount act_kind+      -- foralls and constraints out front. If the actual kind has more, instantiate+      -- accordingly. Otherwise, just pass the type & kind through: the errors+      -- are caught in unifyType.+      n_exp_invis_bndrs = invisibleBndrCount exp_kind+      n_act_invis_bndrs = invisibleBndrCount act_kind       n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs  @@ -2001,7 +1983,9 @@ checkExpKind rn_ty ty ki (Check ki') =   checkExpectedKind rn_ty ty ki ki' checkExpKind _rn_ty ty ki (Infer cell) = do-  co <- fillInferResult ki cell+  -- NB: do not instantiate.+  -- See Note [Do not always instantiate eagerly in types]+  co <- fillInferResultNoInst ki cell   pure (ty `mkCastTy` co)  ---------------------------@@ -2215,12 +2199,10 @@         -- Wrap a context around only if we want to show that contexts.         -- Omit invisible ones and ones user's won't grok addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.-addTypeCtxt (L _ ty) thing-  = addErrCtxt doc thing-  where-    doc = text "In the type" <+> quotes (ppr ty)+addTypeCtxt ty thing = addErrCtxt (TypeCtxt ty) thing  + {- ********************************************************************* *                                                                      *                 Type-variable binders@@ -2430,7 +2412,7 @@                       , hsq_explicit = hs_tvs }) kc_res_ki   -- CUSK case   -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-  = addTyConFlavCtxt name flav $+  = addErrCtxt (TyConDeclCtxt name flav) $     do { skol_info <- mkSkolemInfo skol_info_anon        ; (tclvl, wanted, (scoped_kvs, (tc_bndrs, res_kind)))            <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $@@ -2467,7 +2449,7 @@                       ++ map (mkExplicitTyConBinder mentioned_kv_set) tc_bndrs         -- Eta expand if necessary; we are building a PolyTyCon-       ; (eta_tcbs, res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs res_kind+       ; (eta_tcbs, res_kind) <- maybeEtaExpandAlgTyCon flav skol_info all_tcbs res_kind         ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ binderVars tc_bndrs)              final_tcbs = all_tcbs `chkAppend` eta_tcbs@@ -2531,7 +2513,7 @@                       , hsq_explicit = hs_bndrs }) kc_res_ki   -- No standalone kind signature and no CUSK.   -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-  = addTyConFlavCtxt name flav $+  = addErrCtxt (TyConDeclCtxt name flav) $     do { rejectInvisibleBinders name hs_bndrs        ; (scoped_kvs, (tc_bndrs, res_kind))            -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?@@ -2603,7 +2585,7 @@ kcCheckDeclHeader_sig sig_kind name flav           (HsQTvs { hsq_ext      = implicit_nms                   , hsq_explicit = hs_tv_bndrs }) kc_res_ki-  = addTyConFlavCtxt name flav $+  = addErrCtxt (TyConDeclCtxt name flav) $     do { skol_info <- mkSkolemInfo (TyConSkol flav name)        ; let avoid_occs = map nameOccName (hsLTyVarNames hs_tv_bndrs)        ; (sig_tcbs :: [TcTyConBinder], sig_res_kind :: Kind)@@ -2724,8 +2706,8 @@         ; let -- Drop invisible binders from sig_kind until they match up              -- with res_ki.  By analogy with checkExpectedKind.-             n_res_invis_bndrs = invisibleTyBndrCount actual_res_ki-             n_sig_invis_bndrs = invisibleTyBndrCount sig_kind+             n_res_invis_bndrs = invisibleBndrCount actual_res_ki+             n_sig_invis_bndrs = invisibleBndrCount sig_kind              n_to_inst         = n_sig_invis_bndrs - n_res_invis_bndrs               (_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind@@ -3396,6 +3378,20 @@                                       , hso_bndrs     = exp_bndrs }                     , thing) } +---------------+tcGadtConTyVarBndrs :: SkolemInfo+                    -> HsOuterSigTyVarBndrs GhcRn+                    -> [HsForAllTelescope GhcRn]+                    -> TcM a -> TcM ([TcTyVarBinder], a)+tcGadtConTyVarBndrs skol_info outer inner thing_inside+  = do { (outer_bndrs, (inner_tvbs, a)) <-+            tcOuterTKBndrs skol_info outer $+            tcExplicitTKBndrs skol_info (concatMap hsForAllTelescopeBndrs inner) $+            thing_inside+       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tvbs = tyVarSpecToBinders (outerTyVarBndrs outer_bndrs)+       ; return (outer_tvbs ++ inner_tvbs, a) }+ -------------------------------------- --    Explicit tyvar binders --------------------------------------@@ -3920,14 +3916,20 @@ -}  ------------------------------------etaExpandAlgTyCon :: TyConFlavour tc  -> SkolemInfo+maybeEtaExpandAlgTyCon :: TyConFlavour tc  -> SkolemInfo                   -> [TcTyConBinder] -> Kind                   -> TcM ([TcTyConBinder], Kind)-etaExpandAlgTyCon flav skol_info tcbs res_kind+maybeEtaExpandAlgTyCon flav skol_info tcbs res_kind   | needsEtaExpansion flav-  = splitTyConKind skol_info in_scope avoid_occs res_kind+  = etaExpandAlgTyCon skol_info tcbs res_kind   | otherwise   = return ([], res_kind)++etaExpandAlgTyCon :: SkolemInfo+                  -> [TcTyConBinder] -> Kind+                  -> TcM ([TcTyConBinder], Kind)+etaExpandAlgTyCon skol_info tcbs res_kind+  = splitTyConKind skol_info in_scope avoid_occs res_kind   where     tyvars     = binderVars tcbs     in_scope   = mkInScopeSetList tyvars@@ -3979,7 +3981,9 @@                         name   = mkInternalName uniq occ loc                         tv     = mkTcTyVar name arg' details                         subst' = extendSubstInScope subst tv-                        uniq:uniqs' = uniqs+                        (uniq,uniqs') = case uniqs of+                            uniq:uniqs' -> (uniq,uniqs')+                            _           -> panic "impossible"                         Inf occ occs' = occs                      Just (Named (Bndr tv vis), kind')@@ -4210,7 +4214,7 @@   | HsWC { hswc_ext  = sig_wcs, hswc_body = sig_ty } <- sig_ty   , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty   , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty-  = addSigCtxt ctxt sig_ty $+  = addSigCtxt ctxt (UserLHsSigType sig_ty) $     do { mode <- mkHoleMode TypeLevel HM_Sig        ; (outer_bndrs, (wcs, wcx, theta, tau))             <- solveEqualities "tcHsPartialSigType" $@@ -4437,8 +4441,26 @@   (HsPS { hsps_ext  = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }         , hsps_body = hs_ty })   ctxt_kind-  = tc_type_in_pat ctxt hole_mode hs_ty sig_wcs sig_ns ctxt_kind+  = tc_type_in_pat ctxt Nothing hole_mode hs_ty sig_wcs sig_ns ctxt_kind +tcRuleBndrSig :: Name+              -> SkolemInfo+              -> HsPatSigType GhcRn          -- The type signature+              -> TcM ( [(Name, TcTyVar)]     -- Wildcards+                     , [(Name, TcTyVar)]     -- The new bit of type environment, binding+                                             -- the scoped type variables+                     , TcType)       -- The type+-- Used for type-checking type signatures in+--     RULE forall bndrs  e.g. forall (x::Int). f x = x+-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type+--+-- This may emit constraints+-- See Note [Recipe for checking a signature]+tcRuleBndrSig name skol_info+    (HsPS { hsps_ext  = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }+          , hsps_body = hs_ty })+  = tc_type_in_pat (RuleBndrTypeCtxt name) (Just skol_info)+                   HM_Sig hs_ty sig_wcs sig_ns OpenKind  -- Typecheck type patterns, in data constructor patterns, e.g --    f (MkT @a @(Maybe b) ...) = ...@@ -4461,7 +4483,7 @@   where     all_ns = imp_ns ++ exp_ns     HsTPRn{hstp_nwcs = wcs, hstp_imp_tvs = imp_ns, hstp_exp_tvs = exp_ns} = hstp_rn-    tc_unif_in_pat = tc_type_in_pat TypeAppCtxt HM_TyAppPat+    tc_unif_in_pat = tc_type_in_pat TypeAppCtxt Nothing HM_TyAppPat  -- `tc_bndr_in_pat` is used in type patterns to handle the binders case. -- See Note [Type patterns: binders and unifiers]@@ -4514,6 +4536,7 @@ -- -- * In patterns `tc_type_in_pat` is used to check pattern signatures. tc_type_in_pat :: UserTypeCtxt+               -> Maybe SkolemInfo    -- Just sk for RULE and SPECIALISE pragmas only                -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications.                -> LHsType GhcRn          -- The type in pattern                -> [Name]                 -- All named wildcards in type@@ -4523,9 +4546,10 @@                       , [(Name, TcTyVar)]     -- The new bit of type environment, binding                                               -- the scoped type variables                       , TcType)       -- The type-tc_type_in_pat ctxt hole_mode hs_ty wcs ns ctxt_kind-  = addSigCtxt ctxt hs_ty $-    do { tkv_prs <- mapM new_implicit_tv ns+tc_type_in_pat ctxt mb_skol hole_mode hs_ty wcs ns ctxt_kind+  = addSigCtxt ctxt (UserLHsType hs_ty) $+    do { tkvs <- mapM new_implicit_tv ns+       ; let tkv_prs = ns `zip` tkvs        ; mode <- mkHoleMode TypeLevel hole_mode        ; (wcs, ty)             <- addTypeCtxt hs_ty                $@@ -4555,14 +4579,11 @@   where     new_implicit_tv name       = do { kind <- newMetaKindVar-           ; tv   <- case ctxt of-                       RuleSigCtxt rname _  -> do-                        skol_info <- mkSkolemInfo (RuleSkol rname)-                        newSkolemTyVar skol_info name kind-                       _              -> newPatTyVar name kind-                       -- See Note [Typechecking pattern signature binders]-             -- NB: tv's Name may be fresh (in the case of newPatTyVar)-           ; return (name, tv) }+           ; case mb_skol of+                Just skol_info -> newSkolemTyVar skol_info name kind+                Nothing        -> newPatTyVar name kind }+                -- See Note [Typechecking pattern signature binders]+                -- NB: tv's Name may be fresh (in the case of newPatTyVar)  -- See Note [Type patterns: binders and unifiers] tyPatToBndr :: HsTyPat GhcRn -> Maybe (HsTyVarBndr () GhcRn)@@ -4579,9 +4600,9 @@     Just (HsTvb noAnn () bvar bkind)    go_bvar :: HsType GhcRn -> Maybe (HsBndrVar GhcRn)-  go_bvar (HsTyVar _ _ name)-    | isTyVarName (unLoc name)-    = Just (HsBndrVar noExtField name)+  go_bvar (HsTyVar _ _ tv)+    | isTyVarName (getName tv)+    = Just (HsBndrVar noExtField (fmap getName tv))   go_bvar (HsWildCardTy _)     = Just (HsBndrWildCard noExtField)   go_bvar _ = Nothing@@ -4719,7 +4740,7 @@ tc_lhs_kind_sig mode ctxt hs_kind -- See  Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType -- Result is zonked-  = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $+  = do { kind <- addErrCtxt (KindCtxt hs_kind) $                  solveEqualities "tcLHsKindSig" $                  tc_check_lhs_type mode hs_kind liftedTypeKind        ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)@@ -4740,29 +4761,6 @@ promotionErr :: Name -> PromotionErr -> TcM a promotionErr name err   = failWithTc $ TcRnUnpromotableThing name err--{--************************************************************************-*                                                                      *-          Error messages and such-*                                                                      *-************************************************************************--}----- | Make an appropriate message for an error in a function argument.--- Used for both expressions and types.-funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc-funAppCtxt fun arg arg_no-  = hang (hsep [ text "In the", speakNth arg_no, text "argument of",-                    quotes (ppr fun) <> text ", namely"])-       2 (quotes (ppr arg))---- | Add a "In the data declaration for T" or some such.-addTyConFlavCtxt :: Name -> TyConFlavour tc -> TcM a -> TcM a-addTyConFlavCtxt name flav-  = addErrCtxt $ hsep [ text "In the", ppr flav-                      , text "declaration for", quotes (ppr name) ]  {- ************************************************************************
compiler/GHC/Tc/Gen/Match.hs view
@@ -5,7 +5,10 @@ {-# LANGUAGE TupleSections    #-} {-# LANGUAGE TypeFamilies     #-} {-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE MonadComprehensions  #-}+{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures   #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}  {-@@ -19,7 +22,7 @@    ( tcFunBindMatches    , tcCaseMatches    , tcLambdaMatches-   , tcGRHSList+   , tcGRHSNE    , tcGRHSsPat    , TcStmtChecker    , TcExprStmtChecker@@ -73,13 +76,17 @@ import GHC.Utils.Misc  import GHC.Types.Name+import GHC.Types.Name.Reader import GHC.Types.Id import GHC.Types.SrcLoc import GHC.Types.Basic( VisArity, isDoExpansionGenerated ) +import qualified GHC.Data.List.NonEmpty as NE+ import Control.Monad import Control.Arrow ( second )-import qualified Data.List.NonEmpty as NE+import Data.Foldable (toList)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (mapMaybe)  import qualified GHC.LanguageExtensions as LangExt@@ -114,20 +121,24 @@          ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) -        ; (wrap_fun, (wrap_mult, r))+        ; (wrap_fun, r)              <- matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->                 tcScalingUsage mult $                    -- Makes sure that if the binding is unrestricted, it counts as                    -- consuming its rhs Many times. -                do { traceTc "tcFunBindMatches 2" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys-                                                      , ppr pat_tys $$ ppr rhs_ty ])+                do { traceTc "tcFunBindMatches 2" $+                     vcat [ text "ctxt:" <+> pprUserTypeCtxt ctxt+                          , text "arity:" <+> ppr arity+                          , text "invis_pat_tys:" <+> ppr invis_pat_tys+                          , text "pat_tys:" <+> ppr pat_tys+                          , text "rhs_ty:" <+> ppr rhs_ty ]                    ; tcMatches mctxt tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches } -        ; return (wrap_fun <.> wrap_mult, r) }+        ; return (wrap_fun, r) }   where-    herald = ExpectedFunTyMatches (NameThing fun_name) matches     mctxt  = mkPrefixFunRhs (noLocA fun_name) noAnn+    herald = ExpectedFunTyMatches (NameThing fun_name) matches  funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool funBindPrecondition (MG { mg_alts = L _ alts })@@ -145,11 +156,11 @@   =  do { arity <- checkArgCounts matches             -- Check argument counts since this is also used for \cases -        ; (wrapper, (mult_co_wrap, r))+        ; (wrapper, r)             <- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty ->                tcMatches ctxt tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches -        ; return (wrapper <.> mult_co_wrap, r) }+        ; return (wrapper, r) }   where     ctxt   = LamAlt lam_variant     herald = ExpectedFunTyLam lam_variant e@@ -174,7 +185,7 @@               -> Scaled TcSigmaTypeFRR     -- ^ Type of scrutinee               -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives               -> ExpRhoType                               -- ^ Type of the whole case expression-              -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))+              -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))                 -- Translated alternatives                 -- wrapper goes from MatchGroup's ty to expected ty @@ -186,19 +197,7 @@            -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -- Used for pattern bindings tcGRHSsPat mult grhss res_ty-  = tcScalingUsage mult $ do-    { (mult_co_wrapper, r) <- tcGRHSs PatBindRhs tcBody grhss res_ty-    ; return $ mkWrap mult_co_wrapper r }-  where-    mkWrap wrap grhss@(GRHSs { grhssGRHSs = L loc (GRHS x guards body) : rhss }) =-      grhss { grhssGRHSs = L loc (GRHS x guards (mkLHsWrap wrap body)) : rhss }-    mkWrap _ (GRHSs { grhssGRHSs = [] }) = panic "tcGRHSsPat: empty GHRSs"-    mkWrap _ _ = panic "tcGRHSsPat: non-empty extensions"-    -- Should be the following but it warns of redundant pattern and I couldn't-    -- find a way to silence them-    ---    -- mkWrap _ (GRHSs { grhssGRHSs = L _ (XGRHS absent) : _ }) = dataConCantHappen absent-    -- mkWrap _ (XGRHSs absent) = dataConCantHappen absent+  = tcScalingUsage mult $ tcGRHSs PatBindRhs tcBody grhss res_ty  {- ********************************************************************* *                                                                      *@@ -231,7 +230,7 @@           -> [ExpPatType]             -- ^ Expected pattern types.           -> ExpRhoType               -- ^ Expected result-type of the Match.           -> MatchGroup GhcRn (LocatedA (body GhcRn))-          -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))+          -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))  tcMatches ctxt tc_body pat_tys rhs_ty (MG { mg_alts = L l matches                                           , mg_ext = origin })@@ -247,23 +246,21 @@            [ExpForAllPatTy tvb] -> failWithTc $ TcRnEmptyCase ctxt (EmptyCaseForall tvb)            []                   -> panic "tcMatches: no arguments in EmptyCase"            _t1:(_t2:_ts)        -> panic "tcMatches: multiple arguments in EmptyCase"-       ; rhs_ty  <- expTypeToType rhs_ty-       ; return (idHsWrapper, MG { mg_alts = L l []-                                 , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin-                                 }) }+       ; rhs_ty <- expTypeToType rhs_ty+       ; return (MG { mg_alts = L l []+                    , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin+                    }) }    | otherwise   = do { umatches <- mapM (tcCollectingUsage . tcMatch tc_body pat_tys rhs_ty) matches-       ; let (usages, wmatches) = unzip umatches-       ; let (wrappers, matches') = unzip wmatches-       ; let wrapper = mconcat wrappers+       ; let (usages, matches') = unzip umatches        ; tcEmitBindingUsage $ supUEs usages        ; pat_tys  <- mapM readScaledExpType (filter_out_forall_pat_tys pat_tys)        ; rhs_ty   <- readExpType rhs_ty        ; traceTc "tcMatches" (ppr matches' $$ ppr pat_tys $$ ppr rhs_ty)-       ; return (wrapper, MG { mg_alts   = L l matches'-                             , mg_ext    = MatchGroupTc pat_tys rhs_ty origin-                             }) }+       ; return (MG { mg_alts   = L l matches'+                    , mg_ext    = MatchGroupTc pat_tys rhs_ty origin+                    }) }   where     -- We filter out foralls because we have no use for them in HsToCore.     filter_out_forall_pat_tys :: [ExpPatType] -> [Scaled ExpSigmaTypeFRR]@@ -315,24 +312,24 @@         -> [ExpPatType]          -- Expected pattern types         -> ExpRhoType            -- Expected result-type of the Match.         -> LMatch GhcRn (LocatedA (body GhcRn))-        -> TcM (HsWrapper, LMatch GhcTc (LocatedA (body GhcTc)))+        -> TcM (LMatch GhcTc (LocatedA (body GhcTc)))  tcMatch tc_body pat_tys rhs_ty match-  = do { (L loc (wrapper, r)) <- wrapLocMA (tc_match pat_tys rhs_ty) match-       ; return (wrapper, L loc r) }+  = do { (L loc r) <- wrapLocMA (tc_match pat_tys rhs_ty) match+       ; return (L loc r) }   where     tc_match pat_tys rhs_ty              match@(Match { m_ctxt = ctxt, m_pats = L l pats, m_grhss = grhss })       = add_match_ctxt $-        do { (pats', (wrapper, grhss')) <- tcMatchPats ctxt pats pat_tys $-                                           tcGRHSs ctxt tc_body grhss rhs_ty+        do { (pats', (grhss')) <- tcMatchPats ctxt pats pat_tys $+                                  tcGRHSs ctxt tc_body grhss rhs_ty              -- NB: pats' are just the /value/ patterns              -- See Note [tcMatchPats] in GHC.Tc.Gen.Pat -           ; return (wrapper, Match { m_ext   = noExtField-                                    , m_ctxt  = ctxt-                                    , m_pats  = L l pats'-                                    , m_grhss = grhss' }) }+           ; return (Match { m_ext   = noExtField+                           , m_ctxt  = ctxt+                           , m_pats  = L l pats'+                           , m_grhss = grhss' }) }       where         -- For (\x -> e), tcExpr has already said "In the expression \x->e"         --     so we don't want to add "In the lambda abstraction \x->e"@@ -341,7 +338,7 @@         add_match_ctxt thing_inside = case ctxt of             LamAlt LamSingle -> thing_inside             StmtCtxt (HsDoStmt{}) -> thing_inside -- this is an expanded do stmt-            _          -> addErrCtxt (pprMatchInCtxt match) thing_inside+            _          -> addErrCtxt (MatchInCtxt match) thing_inside  ------------- tcGRHSs :: AnnoBody body@@ -349,23 +346,23 @@         -> TcMatchAltChecker body         -> GRHSs GhcRn (LocatedA (body GhcRn))         -> ExpRhoType-        -> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))+        -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like --      f = \(x::forall a.a->a) -> <stuff> -- We used to force it to be a monotype when there was more than one guard -- but we don't need to do that any more tcGRHSs ctxt tc_body (GRHSs _ grhss binds) res_ty-  = do  { (binds', wrapper, grhss') <- tcLocalBinds binds $ do-                                       tcGRHSList ctxt tc_body grhss res_ty-        ; return (wrapper, GRHSs emptyComments grhss' binds') }+  = do  { (binds', grhss') <- tcLocalBinds binds $ do+                                       tcGRHSNE ctxt tc_body grhss res_ty+        ; return (GRHSs emptyComments grhss' binds') } -tcGRHSList :: forall body. AnnoBody body+tcGRHSNE :: forall body. AnnoBody body            => HsMatchContextRn -> TcMatchAltChecker body-           -> [LGRHS GhcRn (LocatedA (body GhcRn))] -> ExpRhoType-           -> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]-tcGRHSList ctxt tc_body grhss res_ty-   = do { (usages, grhss') <- mapAndUnzipM (wrapLocSndMA tc_alt) grhss+           -> NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn))) -> ExpRhoType+           -> TcM (NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc))))+tcGRHSNE ctxt tc_body grhss res_ty+   = do { (usages, grhss') <- unzip <$> traverse (wrapLocSndMA tc_alt) grhss         ; tcEmitBindingUsage $ supUEs usages         ; return grhss' }    where@@ -480,7 +477,7 @@ -- LetStmts are handled uniformly, regardless of context tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts)                                                              res_ty thing_inside-  = do  { (binds', _, (stmts',thing)) <- tcLocalBinds binds $+  = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $               tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside         ; return (L loc (LetStmt x binds') : stmts', thing) } @@ -499,7 +496,7 @@   | otherwise   = do  { (stmt', (stmts', thing)) <-                 setSrcSpanA loc                             $-                addErrCtxt (pprStmtInCtxt ctxt stmt)        $+                addErrCtxt (StmtErrCtxt ctxt stmt)          $                 stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->                 popErrCtxt                                  $                 tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $@@ -608,25 +605,27 @@         ; (pairs', thing) <- loop env [] bndr_stmts_s         ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }   where-    -- loop :: LocalRdrEnv -- The original LocalRdrEnv-    --      -> [Name]      -- Variables bound by earlier branches-    --      -> [([LStmt GhcRn], [GhcRn])]-    --      -> TcM ([([LStmt GhcTc], [GhcTc])], thing)-    --+    loop+     :: LocalRdrEnv -> [Name] -> NonEmpty (ParStmtBlock GhcRn GhcRn)+     -> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _)     -- Invariant: on entry to `loop`, the LocalRdrEnv is set to     --            origEnv, the LocalRdrEnv for the entire comprehension-    loop _ allBinds [] = do { thing <- bindLocalNames allBinds $ thing_inside elt_ty-                            ; return ([], thing) }   -- matching in the branches--    loop origEnv priorBinds (ParStmtBlock x stmts names _ : pairs)+    loop origEnv priorBinds (ParStmtBlock x stmts names _ :| pairs)       = do { (stmts', (ids, pairs', thing))                 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->                    do { ids <- tcLookupLocalIds names                       ; (pairs', thing) <- setLocalRdrEnv origEnv $-                          loop origEnv (names ++ priorBinds) pairs+                            loop1 origEnv (names ++ priorBinds) pairs                       ; return (ids, pairs', thing) }-           ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }+           ; return ( ParStmtBlock x stmts' ids noSyntaxExpr :| pairs', thing ) } +    loop1+     :: LocalRdrEnv -> [Name] -> [ParStmtBlock GhcRn GhcRn]+     -> TcM ([ParStmtBlock GhcTc GhcTc], _)+    -- matching in the branches+    loop1 _ binds [] = [ ([], a) | a <- bindLocalNames binds (thing_inside elt_ty) ]+    loop1 env binds (x:xs) = [ (toList ys, a) | (ys, a) <- loop env binds (x:|xs) ]+ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts                               , trS_bndrs =  bindersMap                               , trS_by = by, trS_using = using }) elt_ty thing_inside@@ -869,7 +868,7 @@              -- Ensure that every old binder of type `b` is linked up with its              -- new binder which should have type `n b`              -- See Note [TransStmt binder map] in GHC.Hs.Expr-             n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids+             n_bndr_ids = zipWithEqual mk_n_bndr n_bndr_names bndr_ids              bindersMap' = bndr_ids `zip` n_bndr_ids         -- Type check the thing in the environment with@@ -924,20 +923,19 @@        ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty          -- type dummies since we don't know all binder types yet-       ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))-                       [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]+       ; tup_tys_and_bndr_stmts_s <- traverse (\ bndr_stmts@(ParStmtBlock _ _ names _) ->+           [ (tup_tys, bndr_stmts)+           | tup_tys <- mkBigCoreTupTy <$> traverse (const (newFlexiTyVarTy liftedTypeKind)) names ]) bndr_stmts_s         -- Typecheck bind:-       ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]-             tuple_ty = mk_tuple_ty tup_tys+       ; let tuple_ty = mk_tuple_ty (NE.map fst tup_tys_and_bndr_stmts_s)         ; (((blocks', thing), inner_res_ty), bind_op')            <- tcSyntaxOp MCompOrigin bind_op                          [ synKnownType (m_ty `mkAppTy` tuple_ty)                          , SynFun (synKnownType tuple_ty) SynRho ] res_ty $               \ [inner_res_ty] _ ->-              do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)-                                 tup_tys bndr_stmts_s+              do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) tup_tys_and_bndr_stmts_s                  ; return (stuff, inner_res_ty) }         ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }@@ -945,17 +943,10 @@   where     mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys -       -- loop :: Type                                  -- m_ty-       --      -> ExpRhoType                            -- inner_res_ty-       --      -> [TcType]                              -- tup_tys-       --      -> [ParStmtBlock Name]-       --      -> TcM ([([LStmt GhcTc], [TcId])], thing)-    loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty-                                   ; return ([], thing) }-                                   -- matching in the branches--    loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)-                           (ParStmtBlock x stmts names return_op : pairs)+    loop+     :: Type -> ExpRhoType -> NonEmpty (Type, ParStmtBlock GhcRn GhcRn)+     -> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _)+    loop m_ty inner_res_ty ((tup_ty_in, ParStmtBlock x stmts names return_op) :| xs)       = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in            ; (stmts', (ids, return_op', pairs', thing))                 <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $@@ -966,11 +957,17 @@                           tcSyntaxOp MCompOrigin return_op                                      [synKnownType tup_ty] m_tup_ty' $                                      \ _ _ -> return ()-                      ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs+                      ; (pairs', thing) <- loop1 m_ty inner_res_ty xs                       ; return (ids, return_op', pairs', thing) }-           ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }-    loop _ _ _ _ = panic "tcMcStmt.loop"+           ; return (ParStmtBlock x stmts' ids return_op' :| pairs', thing) } +    loop1+     :: Type -> ExpRhoType -> [(Type, ParStmtBlock GhcRn GhcRn)]+     -> TcM ([ParStmtBlock GhcTc GhcTc], _)+    -- matching in the branches+    loop1 _ r [] = [ ([], a) | a <- thing_inside r ]+    loop1 m r (x:xs) = [ (toList ys, a) | (ys, a) <- loop m r (x:|xs) ]+ tcMcStmt _ stmt _ _   = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) @@ -1037,7 +1034,7 @@          ; tcExtendIdEnv tup_ids $ do         { ((stmts', (ret_op', tup_rets)), stmts_ty)-                <- tcInfer $ \ exp_ty ->+                <- runInferRho $ \ exp_ty ->                    tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->                    do { tup_rets <- zipWithM tcCheckId tup_names                                       (map mkCheckExpType tup_elt_tys)@@ -1049,7 +1046,7 @@                       ; return (ret_op', tup_rets) }          ; ((_, mfix_op'), mfix_res_ty)-            <- tcInfer $ \ exp_ty ->+            <- runInferRho $ \ exp_ty ->                tcSyntaxOp DoOrigin mfix_op                           [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $                \ _ _ -> return ()@@ -1175,7 +1172,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside  = do { body_ty <- newFlexiTyVarTy liftedTypeKind       ; let arity = length pairs-      ; ts <- replicateM (arity-1) $ newInferExpType+      ; ts <- replicateM (arity-1) $ newInferExpType IIF_DeepRho       ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind       ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind       ; let fun_ty = mkVisFunTysMany pat_tys body_ty@@ -1218,7 +1215,7 @@                     , ..                     }, pat_ty, exp_ty)       = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $-        addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs))   $+        addErrCtxt (StmtErrCtxt ctxt (mkRnBindStmt pat rhs))   $         do { rhs'      <- tcCheckMonoExprNC rhs exp_ty            ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $                           return ()@@ -1311,4 +1308,4 @@      reqd_args_in_match :: LocatedA (Match GhcRn body1) -> VisArity     -- Counts the number of /required/ (aka visible) args in the match-    reqd_args_in_match (L _ (Match { m_pats = L _ pats })) = count (isVisArgPat . unLoc) pats+    reqd_args_in_match (L _ (Match { m_pats = L _ pats })) = count isVisArgLPat pats
compiler/GHC/Tc/Gen/Pat.hs view
@@ -26,7 +26,7 @@  import GHC.Prelude -import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )+import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferExpr )  import GHC.Hs import GHC.Hs.Syn.Type@@ -73,7 +73,7 @@ import qualified Data.List.NonEmpty as NE  import GHC.Data.List.SetOps ( getNth )-import Language.Haskell.Syntax.Basic (FieldLabelString(..))+import Language.Haskell.Syntax.Basic (FieldLabelString(..), LexicalFixity(..))  import Data.List( partition ) import Control.Monad.Trans.Writer.CPS@@ -101,12 +101,8 @@                        , pe_ctxt = ctxt                        , pe_orig = PatOrigin }        ; dflags <- getDynFlags-       ; mult_co_wrap <- manyIfLazy dflags pat-       -- The wrapper checks for correct multiplicities.-       -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.-       ; (pat', r) <- tc_lpat pat_ty penv pat thing_inside-       ; pat_ty' <- readExpType (scaledThing pat_ty)-       ; return (mkLHsWrapPat mult_co_wrap pat' pat_ty', r) }+       ; manyIfLazy dflags pat+       ; tc_lpat pat_ty penv pat thing_inside }   where     -- The logic is partly duplicated from decideBangHood in     -- GHC.HsToCore.Utils. Ugh…@@ -116,10 +112,10 @@       where         xstrict p@(L _ (LazyPat _ _)) = checkManyPattern LazyPatternReason p pat_ty         xstrict (L _ (ParPat _ p)) = xstrict p-        xstrict _ = return WpHole+        xstrict _ = return () -        not_xstrict (L _ (BangPat _ _)) = return WpHole-        not_xstrict (L _ (VarPat _ _)) = return WpHole+        not_xstrict (L _ (BangPat _ _)) = return ()+        not_xstrict (L _ (VarPat _ _)) = return ()         not_xstrict (L _ (ParPat _ p)) = not_xstrict p         not_xstrict p = checkManyPattern LazyPatternReason p pat_ty @@ -142,7 +138,7 @@ --   Returns only the /value/ patterns; see Note [tcMatchPats]  tcMatchPats match_ctxt pats pat_tys thing_inside-  = assertPpr (count isVisibleExpPatType pat_tys == count (isVisArgPat . unLoc) pats)+  = assertPpr (count isVisibleExpPatType pat_tys == count isVisArgLPat pats)               (ppr pats $$ ppr pat_tys) $        -- Check PRECONDITION        -- When we get @patterns the (length pats) will change@@ -197,8 +193,9 @@              --          f @a t = ... -- loop (InvisPat{} : _) (ExpForAllPatTy (Bndr _ Required) : _)              --      4.  f :: forall {a}. Int              --          f @a t = ... -- loop (InvisPat{} : _) (ExpForAllPatTy (Bndr _ Inferred) : _)-             loop (L loc (InvisPat _ tp) : _) _ =-                failAt (locA loc) (TcRnInvisPatWithNoForAll tp)+             loop (L loc (InvisPat _ tp) : _) _+              = setSrcSpanA loc $+                failWithTc (TcRnIllegalInvisibleTypePattern tp InvisPatNoForall)               -- ExpFunPatTy: expecting a value pattern              -- tc_lpat will error if it sees a @t type pattern@@ -223,7 +220,7 @@            -> TcM a            -> TcM ((LPat GhcTc, a), TcSigmaTypeFRR) tcInferPat frr_orig ctxt pat thing_inside-  = tcInferFRR frr_orig $ \ exp_ty ->+  = runInferSigmaFRR frr_orig $ \ exp_ty ->     tc_lpat (unrestricted exp_ty) penv pat thing_inside  where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }@@ -468,11 +465,10 @@   = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $     tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p)                penv-               (zipEqual "tc_lpats" pats tys)+               (zipEqual pats tys)  ----------------------- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.-checkManyPattern :: NonLinearPatternReason -> LPat GhcRn -> Scaled a -> TcM HsWrapper+checkManyPattern :: NonLinearPatternReason -> LPat GhcRn -> Scaled a -> TcM () checkManyPattern reason pat pat_ty = tcSubMult (NonLinearPatternOrigin reason pat) ManyTy (scaledMult pat_ty)  @@ -523,7 +519,7 @@ pat_to_type (VarPat _ lname)  =   do { tell (tpBuilderExplicitTV (unLoc lname))      ; return b }-  where b = noLocA (HsTyVar noAnn NotPromoted lname)+  where b = noLocA (HsTyVar noAnn NotPromoted $ fmap noUserRdr lname) pat_to_type (WildPat _) = return b   where b = noLocA (HsWildCardTy noExtField) pat_to_type (SigPat _ pat sig_ty)@@ -562,17 +558,17 @@        ; rty <- pat_to_type (unLoc right)        ; let { t = noLocA (HsOpTy noExtField NotPromoted lty lname rty)}        ; pure t }-pat_to_type (ConPat _ lname (PrefixCon invis_args vis_args))-  = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname)}-       ; ty_invis <- foldM apply_invis_arg appHead invis_args-       ; tys_vis <- traverse (pat_to_type . unLoc) vis_args-       ; let t = foldl' mkHsAppTy ty_invis tys_vis-       ; pure t }+pat_to_type (ConPat _ lname (PrefixCon args))+  = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname) }+       ; foldM apply_arg appHead args }       where-        apply_invis_arg :: LHsType GhcRn -> HsConPatTyArg GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn)-        apply_invis_arg !t (HsConPatTyArg _ (HsTP argx arg))+        apply_arg :: LHsType GhcRn -> LPat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn)+        apply_arg !t (L _ (InvisPat _ (HsTP argx arg)))           = do { tell (builderFromHsTyPatRn argx)                ; pure (mkHsAppKindTy noExtField t arg)}+        apply_arg !t (L _ p)+          = do { ty_p <- pat_to_type p+               ; pure (mkHsAppTy t ty_p)}  pat_to_type pat = lift $   failWith $ TcRnIllformedTypePattern pat@@ -628,11 +624,10 @@    VarPat x (L l name) -> do         { (wrap, id) <- tcPatBndr penv name pat_ty-        ; (res, mult_wrap) <- tcCheckUsage name (scaledMult pat_ty) $+        ; res <- tcCheckUsage name (scaledMult pat_ty) $                               tcExtendIdEnv1 name id thing_inside-            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.         ; pat_ty <- readExpType (scaledThing pat_ty)-        ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) }+        ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }    ParPat x pat -> do         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside@@ -653,8 +648,7 @@     ; return (OrPat pat_ty pats', res) }    LazyPat x pat -> do-        { mult_wrap <- checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty-            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.+        { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty         ; (pat', (res, pat_ct))                 <- tc_lpat pat_ty (makeLazy penv) pat $                    captureConstraints thing_inside@@ -668,18 +662,16 @@         ; pat_ty <- readExpType (scaledThing pat_ty)         ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind -        ; return (mkHsWrapPat mult_wrap (LazyPat x pat') pat_ty, res) }+        ; return ((LazyPat x pat'), res) }    WildPat _ -> do-        { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty-            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.+        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty         ; res <- thing_inside         ; pat_ty <- expTypeToType (scaledThing pat_ty)-        ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) }+        ; return (WildPat pat_ty, res) }    AsPat x (L nm_loc name) pat -> do-        { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty-            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.+        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty         ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)         ; (pat', res) <- tcExtendIdEnv1 name bndr_id $                          tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))@@ -692,26 +684,27 @@             --             -- If you fix it, don't forget the bindInstsOfPatIds!         ; pat_ty <- readExpType (scaledThing pat_ty)-        ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }+        ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }    ViewPat _ expr pat -> do-        { mult_wrap <- checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty-         -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.+        { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty          --          -- It should be possible to have view patterns at linear (or otherwise          -- non-Many) multiplicity. But it is not clear at the moment what          -- restriction need to be put in place, if any, for linear view          -- patterns to desugar to type-correct Core. -        ; (expr',expr_ty) <- tcInferRho expr-               -- Note [View patterns and polymorphism]+        ; (expr', expr_rho)    <- tcInferExpr IIF_ShallowRho expr+               -- IIF_ShallowRho: do not perform deep instantiation, regardless of+               -- DeepSubsumption (Note [View patterns and polymorphism])+               -- But we must do top-instantiation to expose the arrow to matchActualFunTy           -- Expression must be a function         ; let herald = ExpectedFunTyViewPat $ unLoc expr         ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)-            <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_ty) expr_ty+            <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho                -- See Note [View patterns and polymorphism]-               -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma)+               -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)           -- Check that overall pattern is more polymorphic than arg type         ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty@@ -724,18 +717,18 @@         ; pat_ty <- readExpType h_pat_ty         ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper                               (Scaled w pat_ty) inf_res_sigma-          -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"-          --                (pat_ty -> inf_res_sigma)-          -- NB: pat_ty comes from matchActualFunTy, so it has a-          -- fixed RuntimeRep, as needed to call mkWpFun.-        ; let-              expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap+              -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"+              --                (pat_ty -> inf_res_sigma)+              -- NB: pat_ty comes from matchActualFunTy, so it has a+              -- fixed RuntimeRep, as needed to call mkWpFun. +              expr_wrap = expr_wrap2' <.> expr_wrap1+         ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }  {- Note [View patterns and polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this exotic example:+Consider this exotic example (test T26331a):    pair :: forall a. Bool -> a -> forall b. b -> (a,b)     f :: Int -> blah@@ -744,11 +737,15 @@ The expression (pair True) should have type     pair True :: Int -> forall b. b -> (Int,b) so that it is ready to consume the incoming Int. It should be an-arrow type (t1 -> t2); hence using (tcInferRho expr).+arrow type (t1 -> t2); and we must not instantiate that `forall b`,+/even with DeepSubsumption/.  Hence using `IIF_ShallowRho`; this is the only+place where `IIF_ShallowRho` is used.  Then, when taking that arrow apart we want to get a *sigma* type (forall b. b->(Int,b)), because that's what we want to bind 'x' to. Fortunately that's what matchActualFunTy returns anyway.++Another example is #26331. -}  -- Type signatures in patterns@@ -777,8 +774,7 @@                                      penv pats thing_inside         ; pat_ty <- readExpType (scaledThing pat_ty)         ; return (mkHsWrapPat coi-                         (ListPat elt_ty pats') pat_ty, res)-}+                         (ListPat elt_ty pats') pat_ty, res) }    TuplePat _ pats boxity -> do         { let arity = length pats@@ -861,9 +857,7 @@ -- -- When there is no negation, neg_lit_ty and lit_ty are the same   NPat _ (L l over_lit) mb_neg eq -> do-        { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty-          -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.-          --+        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty           -- It may be possible to refine linear pattern so that they work in           -- linear environments. But it is not clear how useful this is.         ; let orig = LiteralOrigin over_lit@@ -886,7 +880,7 @@          ; res <- thing_inside         ; pat_ty <- readExpType (scaledThing pat_ty)-        ; return (mkHsWrapPat mult_wrap (NPat pat_ty (L l lit') mb_neg' eq') pat_ty, res) }+        ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }  {- Note [NPlusK patterns]@@ -914,8 +908,7 @@ -- See Note [NPlusK patterns]   NPlusKPat _ (L nm_loc name)                (L loc lit) _ ge minus -> do-        { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty-            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.+        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty         ; let pat_exp_ty = scaledThing pat_ty               orig = LiteralOrigin lit         ; (lit1', ge')@@ -958,7 +951,7 @@                              -- we get warnings if we try. #17783               pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'                                ge' minus''-        ; return (mkHsWrapPat mult_wrap pat' pat_ty, res) }+        ; return (pat', res) }  -- Here we get rid of it and add the finalizers to the global environment. -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.@@ -1050,12 +1043,7 @@        = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty             ; res_ty <- readExpType res_ty   -- should be filled in by now             ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty-            ; let msg = vcat [ hang (text "When checking that the pattern signature:")-                                  4 (ppr sig_ty)-                             , nest 2 (hang (text "fits the type of its context:")-                                          2 (ppr res_ty)) ]-            ; return (tidy_env, msg) }-+            ; return (tidy_env, PatSigErrCtxt sig_ty res_ty) }  {- ********************************************************************* *                                                                      *@@ -1131,12 +1119,13 @@ -- MkT :: forall a b c. (a~[b]) => b -> c -> T a --       with scrutinee of type (T ty) -tcConPat :: PatEnv -> LocatedN Name+tcConPat :: PatEnv -> LocatedN (WithUserRdr Name)          -> Scaled ExpSigmaTypeFRR    -- Type of the pattern          -> HsConPatDetails GhcRn -> TcM a          -> TcM (Pat GhcTc, a)-tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside-  = do  { con_like <- tcLookupConLike con_name+tcConPat penv (L loc qcon) pat_ty arg_pats thing_inside+  = do  { let con_lname = L loc (getName qcon)+        ; con_like <- tcLookupConLike qcon         ; case con_like of             RealDataCon data_con -> tcDataConPat con_lname data_con pat_ty                                                  penv arg_pats thing_inside@@ -1194,7 +1183,7 @@         ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info tenv1 ex_tvs                      -- Get location from monad, not from ex_tvs                      -- This freshens: See Note [Freshen existentials]-                     -- Why "super"? See Note [Binding when looking up instances]+                     -- Why "super"? See Note [Super skolems: binding when looking up instances]                      -- in GHC.Core.InstEnv.          ; let arg_tys'       = substScaledTys tenv arg_tys@@ -1218,16 +1207,21 @@                                    , text "arg_tys':" <+> ppr arg_tys'                                    , text "arg_pats" <+> ppr arg_pats ]) -        ; (univ_ty_args, ex_ty_args) <- splitConTyArgs con_like arg_pats+        ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats +        ; traceTc "tcConPat" (vcat [ text "univ_ty_args:" <+> ppr univ_ty_args+                                   , text "ex_ty_args:"   <+> ppr ex_ty_args+                                   , text "val_arg_pats:" <+> ppr val_arg_pats ])+         ; if null ex_tvs && null eq_spec && null theta           then do { -- The common case; no class bindings etc                     -- (see Note [Arrows and patterns])-                    (arg_pats', res) <- tcConTyArgs tenv penv univ_ty_args $+                    (val_arg_pats', res) <-+                                        tcConTyArgs tenv penv univ_ty_args $                                         tcConValArgs con_like arg_tys_scaled-                                                     penv arg_pats thing_inside+                                                     penv val_arg_pats thing_inside                   ; let res_pat = ConPat { pat_con = header-                                         , pat_args = arg_pats'+                                         , pat_args = val_arg_pats'                                          , pat_con_ext = ConPatTc                                            { cpt_tvs = [], cpt_dicts = []                                            , cpt_binds = emptyTcEvBinds@@ -1244,7 +1238,7 @@                            -- order is *important* as we generate the list of                            -- dictionary binders from theta' -        ; when (not (null eq_spec) || any isEqPred theta) warnMonoLocalBinds+        ; when (not (null eq_spec) || any isEqClassPred theta) warnMonoLocalBinds          ; given <- newEvVars theta'         ; (ev_binds, (arg_pats', res))@@ -1252,7 +1246,7 @@                 tcConTyArgs tenv penv univ_ty_args                       $                 checkConstraints (getSkolemInfo skol_info) ex_tvs' given $                 tcConTyArgs tenv penv ex_ty_args                         $-                tcConValArgs con_like arg_tys_scaled penv arg_pats thing_inside+                tcConValArgs con_like arg_tys_scaled penv val_arg_pats thing_inside          ; let res_pat = ConPat                 { pat_con   = header@@ -1281,9 +1275,10 @@         ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys)         ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv -        ; skol_info <- case pe_ctxt penv of-                            LamPat mc -> mkSkolemInfo (PatSkol (PatSynCon pat_syn) mc)-                            LetPat {} -> return unkSkol -- Doesn't matter+        ; let match_ctxt = case pe_ctxt penv of+                            LamPat mc -> mc+                            LetPat {} -> PatBindRhs+        ; skol_info <- mkSkolemInfo (PatSkol (PatSynCon pat_syn) match_ctxt)          ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info subst ex_tvs            -- This freshens: Note [Freshen existentials]@@ -1296,12 +1291,11 @@               req_theta'  = substTheta tenv req_theta               con_like    = PatSynCon pat_syn -        ; when (any isEqPred prov_theta) warnMonoLocalBinds+        ; when (any isEqClassPred prov_theta) warnMonoLocalBinds -        ; mult_wrap <- checkManyPattern PatternSynonymReason nlWildPatName pat_ty-            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.+        ; checkManyPattern PatternSynonymReason nlWildPatName pat_ty -        ; (univ_ty_args, ex_ty_args) <- splitConTyArgs con_like arg_pats+        ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats          ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' @@ -1336,17 +1330,17 @@          ; traceTc "checkConstraints {" Outputable.empty         ; prov_dicts' <- newEvVars prov_theta'-        ; (ev_binds, (arg_pats', res))+        ; (ev_binds, (val_arg_pats', res))              <- -- See Note [Type applications in patterns] (W4)                 tcConTyArgs tenv penv univ_ty_args                             $                 checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $                 tcConTyArgs tenv penv ex_ty_args                               $-                tcConValArgs con_like arg_tys_scaled penv arg_pats             $+                tcConValArgs con_like arg_tys_scaled penv val_arg_pats         $                 thing_inside         ; traceTc "checkConstraints }" (ppr ev_binds)          ; let res_pat = ConPat { pat_con   = L con_span $ PatSynCon pat_syn-                               , pat_args  = arg_pats'+                               , pat_args  = val_arg_pats'                                , pat_con_ext = ConPatTc                                  { cpt_tvs   = ex_tvs'                                  , cpt_dicts = prov_dicts'@@ -1356,7 +1350,7 @@                                  }                                }         ; pat_ty <- readExpType (scaledThing pat_ty)-        ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) }+        ; return (mkHsWrapPat wrap res_pat pat_ty, res) }  checkFixedRuntimeRep :: DataCon -> [Scaled TcSigmaTypeFRR] -> TcM () checkFixedRuntimeRep data_con arg_tys@@ -1382,12 +1376,12 @@ This is achieve easily, but a bit trickily.  When we instantiate Annotated's "required" constraints, in tcPatSynPat, give them a CtOrigin of (OccurrenceOf "Annotated"). That way the special magic-in GHC.Tc.Solver.Dict.solveCallStack which deals with CallStack+in GHC.Tc.Solver.Dict.canDictCt which deals with CallStack constraints will kick in: that logic only fires on constraints 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.Types+and Note [Solving CallStack constraints] in GHC.Tc.Solver.Dict -} ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function@@ -1607,44 +1601,44 @@ weren't for linearity checking, the type checker could ignore b altogether. So we have a function check_omitted_fields_multiplicity, whose purpose is to do the linearity checking on the omitted fields.--check_omitted_fields_multiplicity returns coercions which all need to be-reflexivity after zonking: see Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify. -}  tcConValArgs :: ConLike              -> [Scaled TcSigmaTypeFRR]              -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) tcConValArgs con_like arg_tys penv con_args thing_inside = case con_args of-  PrefixCon type_args arg_pats -> do-        -- NB: type_args already dealt with+  PrefixCon arg_pats -> do+        -- NB: Type arguments already dealt with by splitConTyArgs, tcConTyArgs.         -- See Note [Type applications in patterns]-        { checkTc (con_arity == no_of_args)     -- Check correct arity-                  (TcRnArityMismatch (AConLike con_like) con_arity no_of_args)--        ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys+        { report_invis_arg_pats arg_pats+        ; let pats_w_tys = zipEqual arg_pats arg_tys         ; (arg_pats', res) <- tcMultiple tcConArg penv pats_w_tys thing_inside -        ; return (PrefixCon type_args arg_pats', res) }-    where-      con_arity  = conLikeArity con_like-      no_of_args = length arg_pats+        -- Return only /value/ patterns, all /type/ patterns are discarded.+        -- This is also what tcMatchPats does, and Note [tcMatchPats] explains why.+        ; return (PrefixCon arg_pats', res) }+      where+        -- Report @-patterns as errors. The valid ones have been dealt with+        -- outside tcConValArgs. At this point we are expecting patterns for+        -- value arguments only.+        report_invis_arg_pats :: [LPat GhcRn] -> TcM ()+        report_invis_arg_pats ps = do+          let bad_ps = [L loc tp | L loc (InvisPat _ tp) <- ps]+          forM_ bad_ps $ \(L loc tp) ->+            setSrcSpanA loc $+            addErrTc (TcRnIllegalInvisibleTypePattern tp InvisPatNoForall)+          unless (null bad_ps) failM    InfixCon p1 p2 -> do-        { checkTc (con_arity == 2)      -- Check correct arity-                  (TcRnArityMismatch (AConLike con_like) con_arity 2)-        ; let [arg_ty1,arg_ty2] = arg_tys       -- This can't fail after the arity check+        { let [arg_ty1,arg_ty2] = arg_tys       -- This can't fail after splitConTyArgs         ; ([p1',p2'], res) <- tcMultiple tcConArg penv [(p1,arg_ty1),(p2,arg_ty2)]                                                   thing_inside         ; return (InfixCon p1' p2', res) }-    where-      con_arity  = conLikeArity con_like -  RecCon (HsRecFields _ rpats dd) -> do-        { mult_cos <- check_omitted_fields_multiplicity-           -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.+  RecCon (HsRecFields x rpats dd) -> do+        { check_omitted_fields_multiplicity         ; (rpats', res) <- tcMultiple tc_field penv rpats thing_inside-        ; return ((RecCon (HsRecFields mult_cos rpats' dd)), res) }+        ; return ((RecCon (HsRecFields x rpats' dd)), res) }     where       tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))                           (LHsRecField GhcTc (LPat GhcTc))@@ -1658,11 +1652,10 @@              ; return (L l (HsFieldBind ann (L loc (FieldOcc rdr (L lr sel'))) pat'                                                                         pun), res) }       -- See Note [Omitted record fields and linearity]-      check_omitted_fields_multiplicity :: TcM MultiplicityCheckCoercions+      check_omitted_fields_multiplicity :: TcM ()       check_omitted_fields_multiplicity = do-        mult_coss <- forM omitted_field_tys $ \(fl, pat_ty) ->-          tcSubMult' (OmittedFieldOrigin fl) ManyTy (scaledMult pat_ty)-        return $ concat mult_coss+        forM_ omitted_field_tys $ \(fl, pat_ty) ->+          tcSubMult (OmittedFieldOrigin fl) ManyTy (scaledMult pat_ty)        find_field_ty :: Name -> FastString -> TcM (Scaled TcType)       find_field_ty sel lbl@@ -1698,44 +1691,78 @@       con_field_labels :: [Maybe FieldLabel]       con_field_labels = (map Just (conLikeFieldLabels con_like)) ++ repeat Nothing +check_con_pat_arity :: ConLike -> Int -> TcM ()+check_con_pat_arity con_like no_of_vis_args =+  checkTc (con_vis_arity == no_of_vis_args)+          (TcRnArityMismatch (AConLike con_like) con_vis_arity no_of_vis_args)+  where+    con_vis_arity = conLikeVisArity con_like  splitConTyArgs :: ConLike -> HsConPatDetails GhcRn-               -> TcM ( [(HsConPatTyArg GhcRn, TyVar)]    -- Universals-                      , [(HsConPatTyArg GhcRn, TyVar)] )  -- Existentials+               -> TcM ( [(HsTyPat GhcRn, TyVar)]    -- Universals+                      , [(HsTyPat GhcRn, TyVar)]    -- Existentials+                      , HsConPatDetails GhcRn )     -- Value arguments -- See Note [Type applications in patterns] (W4)--- This function is monadic only because of the error check--- for too many type arguments-splitConTyArgs con_like (PrefixCon type_args _)-  = do { checkTc (type_args `leLength` con_spec_bndrs)-                 (TcRnTooManyTyArgsInConPattern con_like-                          (length con_spec_bndrs) (length type_args))-       ; if null ex_tvs  -- Short cut common case-         then return (bndr_ty_arg_prs, [])-         else return (partition is_universal bndr_ty_arg_prs) }+-- This function is monadic only to emit error messages+splitConTyArgs con_like (PrefixCon arg_pats) = do+  check_con_pat_arity con_like (count isVisArgLPat arg_pats)+  split_con_ty_args Prefix con_like arg_pats+splitConTyArgs con_like (InfixCon arg1 arg2) = do+  -- should not occur: (@a :+ b), (a :+ @b), or (@a :+ @b)+  massert (isVisArgLPat arg1 && isVisArgLPat arg2)+  check_con_pat_arity con_like 2+  split_con_ty_args Infix con_like [arg1, arg2]+splitConTyArgs _ p@(RecCon {}) = return ([], [], p) -- No type args in RecCon++split_con_ty_args :: LexicalFixity        -- How to wrap value arguments+                  -> ConLike              -- Data constructor or pattern synonym+                  -> [LPat GhcRn]         -- Argument patterns+                  -> TcM ( [(HsTyPat GhcRn, TyVar)]   -- Universals+                         , [(HsTyPat GhcRn, TyVar)]   -- Existentials+                         , HsConPatDetails GhcRn )    -- Value arguments+split_con_ty_args fixity con_like arg_pats = do+  (bndr_ty_arg_prs, value_args) <- zip_pats_bndrs arg_pats (conLikeUserTyVarBinders con_like)+  return $ if null ex_tvs  -- Short cut common case+           then (bndr_ty_arg_prs, [], mk_details fixity value_args)+           else let (ex_prs, univ_prs) = partition is_existential bndr_ty_arg_prs+                in (univ_prs, ex_prs, mk_details fixity value_args)   where     ex_tvs = conLikeExTyCoVars con_like-    con_spec_bndrs = [ tv | Bndr tv SpecifiedSpec <- conLikeUserTyVarBinders con_like ]-        -- conLikeUserTyVarBinders: see (W3) in-        --    Note [Type applications in patterns]-        -- SpecifiedSpec: forgetting to filter out inferred binders led to #20443--    bndr_ty_arg_prs = type_args `zip` con_spec_bndrs-                      -- The zip truncates to length(type_args)+    is_existential (_, tv) = tv `elem` ex_tvs+          -- See Note [DataCon user type variable binders] in GHC.Core.DataCon+          -- especially INVARIANT(dataConTyVars). -    is_universal (_, tv) = not (tv `elem` ex_tvs)-         -- See Note [DataCon user type variable binders] in GHC.Core.DataCon-         -- especially INVARIANT(dataConTyVars).+    mk_details Infix [a,b] = InfixCon a b+    mk_details _     ps    = PrefixCon ps+      -- InfixCon becomes PrefixCon if there are fewer than 2 value arguments.+      -- Test case: T25127_infix -splitConTyArgs _ (RecCon {})   = return ([], []) -- No type args in RecCon-splitConTyArgs _ (InfixCon {}) = return ([], []) -- No type args in InfixCon+zip_pats_bndrs :: [LPat GhcRn] -> [TyVarBinder] -> TcM ([(HsTyPat GhcRn, TyVar)], [LPat GhcRn])+zip_pats_bndrs (L loc pat : pats) (Bndr tv vis : tvbs)+  | isVisibleForAllTyFlag vis+  = do { tp <- setSrcSpanA loc $ pat_to_type_pat pat+       ; (prs, pats') <- zip_pats_bndrs pats tvbs+       ; return ((tp, tv) : prs, pats') }+  | InvisPat pat_spec tp <- pat+  , Invisible spec <- vis+  , pat_spec == spec+  = do { (prs, pats') <- zip_pats_bndrs pats tvbs+       ; return ((tp, tv):prs, pats') }+zip_pats_bndrs pats (Bndr _ vis : tvbs)+  -- zip_pats_bndrs [] (Bndr _ Required : tvbs)+  --   is ruled out by the arity check in splitConTyArgs,+  --   so we can assume (isInvisibleForAllTyFlag vis)+  = do { massert (isInvisibleForAllTyFlag vis)+       ; zip_pats_bndrs pats tvbs }+zip_pats_bndrs pats [] = return ([], pats) -tcConTyArgs :: Subst -> PatEnv -> [(HsConPatTyArg GhcRn, TyVar)]+tcConTyArgs :: Subst -> PatEnv -> [(HsTyPat GhcRn, TyVar)]             -> TcM a -> TcM a tcConTyArgs tenv penv prs thing_inside   = tcMultiple_ (tcConTyArg tenv) penv prs thing_inside -tcConTyArg :: Subst -> Checker (HsConPatTyArg GhcRn, TyVar) ()-tcConTyArg tenv penv (HsConPatTyArg _ rn_ty, con_tv) thing_inside+tcConTyArg :: Subst -> Checker (HsTyPat GhcRn, TyVar) ()+tcConTyArg tenv penv (rn_ty, con_tv) thing_inside   = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsTyPat rn_ty (substTy tenv (varType con_tv))         ; case NE.nonEmpty sig_ibs of@@ -1889,14 +1916,13 @@ -- Not all patterns are worth pushing a context maybeWrapPatCtxt pat tcm thing_inside   | not (worth_wrapping pat) = tcm thing_inside-  | otherwise                = addErrCtxt msg $ tcm $ popErrCtxt thing_inside+  | otherwise                = addErrCtxt (PatCtxt pat) $ tcm $ popErrCtxt thing_inside                                -- Remember to pop before doing thing_inside   where    worth_wrapping (VarPat {}) = False    worth_wrapping (ParPat {}) = False    worth_wrapping (AsPat {})  = False    worth_wrapping _           = True-   msg = hang (text "In the pattern:") 2 (ppr pat)  ----------------------------------------------- 
− compiler/GHC/Tc/Gen/Rule.hs 
@@ -1,529 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--{--(c) The University of Glasgow 2006-(c) The AQUA Project, Glasgow University, 1993-1998---}---- | Typechecking rewrite rules-module GHC.Tc.Gen.Rule ( tcRules ) where--import GHC.Prelude--import GHC.Hs-import GHC.Tc.Types-import GHC.Tc.Utils.Monad-import GHC.Tc.Solver-import GHC.Tc.Solver.Monad ( runTcS )-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin-import GHC.Tc.Utils.TcMType-import GHC.Tc.Utils.TcType-import GHC.Tc.Gen.HsType-import GHC.Tc.Gen.Expr-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Unify( buildImplicationFor )-import GHC.Tc.Zonk.TcType--import GHC.Core.Type-import GHC.Core.Coercion( mkCoVarCo )-import GHC.Core.TyCon( isTypeFamilyTyCon )-import GHC.Core.Predicate--import GHC.Types.Id-import GHC.Types.Var( EvVar, tyVarName )-import GHC.Types.Var.Set-import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) )-import GHC.Types.SrcLoc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Data.Bag--{--Note [Typechecking rules]-~~~~~~~~~~~~~~~~~~~~~~~~~-We *infer* the typ of the LHS, and use that type to *check* the type of-the RHS.  That means that higher-rank rules work reasonably well. Here's-an example (test simplCore/should_compile/rule2.hs) produced by Roman:--   foo :: (forall m. m a -> m b) -> m a -> m b-   foo f = ...--   bar :: (forall m. m a -> m a) -> m a -> m a-   bar f = ...--   {-# RULES "foo/bar" foo = bar #-}--He wanted the rule to typecheck.--Note [TcLevel in type checking rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Bringing type variables into scope naturally bumps the TcLevel. Thus, we type-check the term-level binders in a bumped level, and we must accordingly bump-the level whenever these binders are in scope.--Note [Re-quantify type variables in rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this example from #17710:--  foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b-  foo x = Proxy-  {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-}--Written out in more detail, the "foo" rewrite rule looks like this:--  forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0--Where b0 is a unification variable. Where should b0 be quantified? We have to-quantify it after k, since (b0 :: k). But generalization usually puts inferred-type variables (such as b0) at the /front/ of the telescope! This creates a-conflict.--One option is to simply throw an error, per the principles of-Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen-if we were generalising over a normal type signature. On the other hand, the-types in a rewrite rule aren't quite "normal", since the notions of specified-and inferred type variables aren't applicable.--A more permissive design (and the design that GHC uses) is to simply requantify-all of the type variables. That is, we would end up with this:--  forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b--It's a bit strange putting the generalized variable `b` after the user-written-variables `k` and `a`. But again, the notion of specificity is not relevant to-rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not-only makes "foo" typecheck, but it also makes the implementation simpler.--See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which-explains a very similar design when generalising over a type family instance-equation.--}--tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc]-tcRules decls = mapM (wrapLocMA tcRuleDecls) decls--tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)-tcRuleDecls (HsRules { rds_ext = src-                     , rds_rules = decls })-   = do { maybe_tc_decls <- mapM (wrapLocMA tcRule) decls-        ; let tc_decls = [L loc rule | (L loc (Just rule)) <- maybe_tc_decls]-        ; return $ HsRules { rds_ext   = src-                           , rds_rules = tc_decls } }---tcRule :: RuleDecl GhcRn -> TcM (Maybe (RuleDecl GhcTc))-tcRule (HsRule { rd_ext  = ext-               , rd_name = rname@(L _ name)-               , rd_act  = act-               , rd_tyvs = ty_bndrs-               , rd_tmvs = tm_bndrs-               , rd_lhs  = lhs-               , rd_rhs  = rhs })-  = addErrCtxt (ruleCtxt name)  $-    do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname)-       ; skol_info <- mkSkolemInfo (RuleSkol name)-        -- Note [Typechecking rules]-       ; (tc_lvl, stuff) <- pushTcLevelM $-                            generateRuleConstraints name ty_bndrs tm_bndrs lhs rhs--       ; let (id_bndrs, lhs', lhs_wanted-                      , rhs', rhs_wanted, rule_ty) = stuff--       ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname-                                  , ppr lhs_wanted-                                  , ppr rhs_wanted ])--       ; (lhs_evs, residual_lhs_wanted, dont_default)-            <- simplifyRule name tc_lvl lhs_wanted rhs_wanted--       -- SimplifyRule Plan, step 4-       -- Now figure out what to quantify over-       -- c.f. GHC.Tc.Solver.simplifyInfer-       -- We quantify over any tyvars free in *either* the rule-       --  *or* the bound variables.  The latter is important.  Consider-       --      ss (x,(y,z)) = (x,z)-       --      RULE:  forall v. fst (ss v) = fst v-       -- The type of the rhs of the rule is just a, but v::(a,(b,c))-       ---       -- We also need to get the completely-unconstrained tyvars of-       -- the LHS, lest they otherwise get defaulted to Any; but we do that-       -- during zonking (see GHC.Tc.Zonk.Type.zonkRule)--       ; let tpl_ids = lhs_evs ++ id_bndrs--       -- See Note [Re-quantify type variables in rules]-       ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)-       ; let weed_out = (`dVarSetMinusVarSet` dont_default)-             quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs)-                                       , dv_tvs = weed_out (dv_tvs forall_tkvs) }-       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands-       ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname-                                , text "forall_tkvs:" <+> ppr forall_tkvs-                                , text "quant_cands:" <+> ppr quant_cands-                                , text "dont_default:" <+> ppr dont_default-                                , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted-                                , text "qtkvs:" <+> ppr qtkvs-                                , text "rule_ty:" <+> ppr rule_ty-                                , text "ty_bndrs:" <+> ppr ty_bndrs-                                , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids)-                                , text "tpl_id info:" <+>-                                  vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]-                  ])--       -- SimplfyRule Plan, step 5-       -- Simplify the LHS and RHS constraints:-       -- For the LHS constraints we must solve the remaining constraints-       -- (a) so that we report insoluble ones-       -- (b) so that we bind any soluble ones-       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs-                                         lhs_evs residual_lhs_wanted-       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs-                                         lhs_evs rhs_wanted-       ; emitImplications (lhs_implic `unionBags` rhs_implic)--       -- A type error on the LHS of a rule will be reported earlier while solving for-       -- lhs_implic. However, we should also drop the rule entirely for cases where-       -- compilation continues regardless of the error. For example with-       -- `-fdefer-type-errors`, where this ill-typed LHS rule may cause follow-on errors-       -- (#24026).-       ; if anyBag insolubleImplic lhs_implic-        then-          return Nothing -- The RULE LHS does not type-check and will be dropped.-        else-          return . Just $ HsRule { rd_ext = ext-                         , rd_name = rname-                         , rd_act = act-                         , rd_tyvs = ty_bndrs -- preserved for ppr-ing-                         , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA)-                                         (qtkvs ++ tpl_ids)-                         , rd_lhs  = mkHsDictLet lhs_binds lhs'-                         , rd_rhs  = mkHsDictLet rhs_binds rhs' } }--generateRuleConstraints :: FastString-                        -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]-                        -> LHsExpr GhcRn -> LHsExpr GhcRn-                        -> TcM ( [TcId]-                               , LHsExpr GhcTc, WantedConstraints-                               , LHsExpr GhcTc, WantedConstraints-                               , TcType )-generateRuleConstraints rule_name ty_bndrs tm_bndrs lhs rhs-  = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $-                                                tcRuleBndrs rule_name ty_bndrs tm_bndrs-              -- bndr_wanted constraints can include wildcard hole-              -- constraints, which we should not forget about.-              -- It may mention the skolem type variables bound by-              -- the RULE.  c.f. #10072-       ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $-         tcExtendIdEnv    id_bndrs $-    do { -- See Note [Solve order for RULES]-         ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)-       ; (rhs',            rhs_wanted) <- captureConstraints $-                                          tcCheckMonoExpr rhs rule_ty-       ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted-       ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }---- See Note [TcLevel in type checking rules]-tcRuleBndrs :: FastString -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]-            -> TcM ([TcTyVar], [Id])-tcRuleBndrs rule_name (Just bndrs) xs-  = do { skol_info <- mkSkolemInfo (RuleSkol rule_name)-       ; (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info bndrs $-                                  tcRuleTmBndrs rule_name xs-       ; let tys1 = binderVars tybndrs1-       ; return (tys1 ++ tys2, tms) }--tcRuleBndrs rule_name Nothing xs-  = tcRuleTmBndrs rule_name xs---- See Note [TcLevel in type checking rules]-tcRuleTmBndrs :: FastString -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])-tcRuleTmBndrs _ [] = return ([],[])-tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs)-  = do  { ty <- newOpenFlexiTyVarTy-        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs-        ; return (tyvars, mkLocalId name ManyTy ty : tmvars) }-tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)---  e.g         x :: a->a---  The tyvar 'a' is brought into scope first, just as if you'd written---              a::*, x :: a->a---  If there's an explicit forall, the renamer would have already reported an---   error for each out-of-scope type variable used-  = do  { let ctxt = RuleSigCtxt rule_name name-        ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind-        ; let id  = mkLocalId name ManyTy id_ty-                    -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType--              -- The type variables scope over subsequent bindings; yuk-        ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $-                                   tcRuleTmBndrs rule_name rule_bndrs-        ; return (map snd tvs ++ tyvars, id : tmvars) }--ruleCtxt :: FastString -> SDoc-ruleCtxt name = text "When checking the rewrite rule" <+>-                doubleQuotes (ftext name)---{--*********************************************************************************-*                                                                                 *-              Constraint simplification for rules-*                                                                                 *-***********************************************************************************--Note [The SimplifyRule Plan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Example.  Consider the following left-hand side of a rule-        f (x == y) (y > z) = ...-If we typecheck this expression we get constraints-        d1 :: Ord a, d2 :: Eq a-We do NOT want to "simplify" to the LHS-        forall x::a, y::a, z::a, d1::Ord a.-          f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...-Instead we want-        forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.-          f ((==) d2 x y) ((>) d1 y z) = ...--Here is another example:-        fromIntegral :: (Integral a, Num b) => a -> b-        {-# RULES "foo"  fromIntegral = id :: Int -> Int #-}-In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But-we *dont* want to get-        forall dIntegralInt.-           fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int-because the scsel will mess up RULE matching.  Instead we want-        forall dIntegralInt, dNumInt.-          fromIntegral Int Int dIntegralInt dNumInt = id Int--Even if we have-        g (x == y) (y == z) = ..-where the two dictionaries are *identical*, we do NOT WANT-        forall x::a, y::a, z::a, d1::Eq a-          f ((==) d1 x y) ((>) d1 y z) = ...-because that will only match if the dict args are (visibly) equal.-Instead we want to quantify over the dictionaries separately.--In short, simplifyRuleLhs must *only* squash equalities, leaving-all dicts unchanged, with absolutely no sharing.--Also note that we can't solve the LHS constraints in isolation:-Example   foo :: Ord a => a -> a-          foo_spec :: Int -> Int-          {-# RULE "foo"  foo = foo_spec #-}-Here, it's the RHS that fixes the type variable--HOWEVER, under a nested implication things are different-Consider-  f :: (forall a. Eq a => a->a) -> Bool -> ...-  {-# RULES "foo" forall (v::forall b. Eq b => b->b).-       f b True = ...-    #-}-Here we *must* solve the wanted (Eq a) from the given (Eq a)-resulting from skolemising the argument type of g.  So we-revert to SimplCheck when going under an implication.------------ So the SimplifyRule Plan is this -------------------------* Step 0: typecheck the LHS and RHS to get constraints from each--* Step 1: Simplify the LHS and RHS constraints all together in one bag,-          but /discarding/ the simplified constraints. We do this only-          to discover all unification equalities.--* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take-          advantage of those unifications--* Setp 3: Partition the LHS constraints into the ones we will-          quantify over, and the others.-          See Note [RULE quantification over equalities]--* Step 4: Decide on the type variables to quantify over--* Step 5: Simplify the LHS and RHS constraints separately, using the-          quantified constraints as givens--Note [Solve order for RULES]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In step 1 above, we need to be a bit careful about solve order.-Consider-   f :: Int -> T Int-   type instance T Int = Bool--   RULE f 3 = True--From the RULE we get-   lhs-constraints:  T Int ~ alpha-   rhs-constraints:  Bool ~ alpha-where 'alpha' is the type that connects the two.  If we glom them-all together, and solve the RHS constraint first, we might solve-with alpha := Bool.  But then we'd end up with a RULE like--    RULE: f 3 |> (co :: T Int ~ Bool) = True--which is terrible.  We want--    RULE: f 3 = True |> (sym co :: Bool ~ T Int)--So we are careful to solve the LHS constraints first, and *then* the-RHS constraints.  Actually much of this is done by the on-the-fly-constraint solving, so the same order must be observed in-tcRule.---Note [RULE quantification over equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Deciding which equalities to quantify over is tricky:- * We do not want to quantify over insoluble equalities (Int ~ Bool)-    (a) because we prefer to report a LHS type error-    (b) because if such things end up in 'givens' we get a bogus-        "inaccessible code" error-- * But we do want to quantify over things like (a ~ F b), where-   F is a type function.--The difficulty is that it's hard to tell what is insoluble!-So we see whether the simplification step yielded any type errors,-and if so refrain from quantifying over *any* equalities.--Note [Quantifying over coercion holes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Equality constraints from the LHS will emit coercion hole Wanteds.-These don't have a name, so we can't quantify over them directly.-Instead, because we really do want to quantify here, invent a new-EvVar for the coercion, fill the hole with the invented EvVar, and-then quantify over the EvVar. Not too tricky -- just some-impedance matching, really.--Note [Simplify cloned constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At this stage, we're simplifying constraints only for insolubility-and for unification. Note that all the evidence is quickly discarded.-We use a clone of the real constraint. If we don't do this,-then RHS coercion-hole constraints get filled in, only to get filled-in *again* when solving the implications emitted from tcRule. That's-terrible, so we avoid the problem by cloning the constraints.---}--simplifyRule :: RuleName-             -> TcLevel                 -- Level at which to solve the constraints-             -> WantedConstraints       -- Constraints from LHS-             -> WantedConstraints       -- Constraints from RHS-             -> TcM ( [EvVar]               -- Quantify over these LHS vars-                    , WantedConstraints     -- Residual un-quantified LHS constraints-                    , TcTyVarSet )          -- Don't default these--- See Note [The SimplifyRule Plan]--- NB: This consumes all simple constraints on the LHS, but not--- any LHS implication constraints.-simplifyRule name tc_lvl lhs_wanted rhs_wanted-  = do {-       -- Note [The SimplifyRule Plan] step 1-       -- First solve the LHS and *then* solve the RHS-       -- Crucially, this performs unifications-       -- Why clone?  See Note [Simplify cloned constraints]-       ; lhs_clone <- cloneWC lhs_wanted-       ; rhs_clone <- cloneWC rhs_wanted-       ; (dont_default, _)-            <- setTcLevel tc_lvl $-               runTcS            $-               do { lhs_wc  <- solveWanteds lhs_clone-                  ; _rhs_wc <- solveWanteds rhs_clone-                        -- Why do them separately?-                        -- See Note [Solve order for RULES]--                  ; let dont_default = nonDefaultableTyVarsOfWC lhs_wc-                        -- If lhs_wanteds has-                        --   (a[sk] :: TYPE rr[sk]) ~ (b0[tau] :: TYPE r0[conc])-                        -- we want r0 to be non-defaultable;-                        -- see nonDefaultableTyVarsOfWC.  Simplest way to get-                        -- this is to look at the post-simplified lhs_wc, which-                        -- will contain (rr[sk] ~ r0[conc)].  An example is in-                        -- test rep-poly/RepPolyRule1-                  ; return dont_default }--       -- Note [The SimplifyRule Plan] step 2-       ; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted-       ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted--       -- Note [The SimplifyRule Plan] step 3-       ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)--       ; traceTc "simplifyRule" $-         vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)-              , text "lhs_wanted" <+> ppr lhs_wanted-              , text "rhs_wanted" <+> ppr rhs_wanted-              , text "quant_cts" <+> ppr quant_cts-              , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted-              , text "dont_default" <+> ppr dont_default-              ]--       ; return (quant_evs, residual_lhs_wanted, dont_default) }--  where-    mk_quant_ev :: Ct -> TcM EvVar-    mk_quant_ev ct-      | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct-      = case dest of-          EvVarDest ev_id -> return ev_id-          HoleDest hole   -> -- See Note [Quantifying over coercion holes]-                             do { ev_id <- newEvVar pred-                                ; fillCoercionHole hole (mkCoVarCo ev_id)-                                ; return ev_id }-    mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)---getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)--- Extract all the constraints we can quantify over,---   also returning the depleted WantedConstraints------ NB: we must look inside implications, because with---     -fdefer-type-errors we generate implications rather eagerly;---     see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732.------ Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,---   and attempt to solve them from the quantified constraints.  That---   nearly works, but fails for a constraint like (d :: Eq Int).---   We /do/ want to quantify over it, but the short-cut solver---   (see GHC.Tc.Solver.Dict Note [Shortcut solving]) ignores the quantified---   and instead solves from the top level.------   So we must partition the WantedConstraints ourselves---   Not hard, but tiresome.--getRuleQuantCts wc-  = float_wc emptyVarSet wc-  where-    float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)-    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })-      = ( simple_yes `andCts` implic_yes-        , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs })-     where-        (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples-        (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)-                                                emptyBag implics--    float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication)-    float_implic skol_tvs yes1 imp-      = (yes1 `andCts` yes2, imp { ic_wanted = no })-      where-        (yes2, no) = float_wc new_skol_tvs (ic_wanted imp)-        new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp--    rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool-    rule_quant_ct skol_tvs ct = case classifyPredType (ctPred ct) of-      EqPred _ t1 t2-        | not (ok_eq t1 t2)-        -> False        -- Note [RULE quantification over equalities]-      _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs--    ok_eq t1 t2-       | t1 `tcEqType` t2 = False-       | otherwise        = is_fun_app t1 || is_fun_app t2--    is_fun_app ty   -- ty is of form (F tys) where F is a type function-      = case tyConAppTyCon_maybe ty of-          Just tc -> isTypeFamilyTyCon tc-          Nothing -> False
compiler/GHC/Tc/Gen/Sig.hs view
@@ -19,7 +19,9 @@         TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,        mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,-       addInlinePrags, addInlinePragArity+       addInlinePrags, addInlinePragArity,++       tcRules    ) where  import GHC.Prelude@@ -30,29 +32,40 @@  import GHC.Hs +import {-# SOURCE #-} GHC.Tc.Gen.Expr  ( tcInferRho, tcCheckMonoExpr ) -import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) )+import GHC.Tc.Errors.Types import GHC.Tc.Gen.HsType-import GHC.Tc.Types-import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )+import GHC.Tc.Solver( reportUnsolvedEqualities, pushLevelAndSolveEqualitiesX+                    , emitResidualConstraints )+import GHC.Tc.Solver.Solve( solveWanteds )+import GHC.Tc.Solver.Monad( runTcS, setTcSMode, TcSMode(..), vanillaTcSMode, runTcSWithEvBinds )+import GHC.Tc.Validity ( checkValidType )+ import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep, newOpenTypeKind )-import GHC.Tc.Zonk.Type-import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType-import GHC.Tc.Validity ( checkValidType )-import GHC.Tc.Utils.Unify( DeepSubsumptionFlag(..), tcSkolemise, unifyType )+import GHC.Tc.Utils.TcMType+import GHC.Tc.Utils.Unify( DeepSubsumptionFlag(..), tcSkolemise, unifyType, buildImplicationFor ) import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs )-import GHC.Tc.Utils.Env( tcLookupId )-import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )+import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Constraint++import GHC.Tc.Zonk.TcType+import GHC.Tc.Zonk.Type+ import GHC.Core( hasSomeUnfolding )-import GHC.Core.Type ( mkTyVarBinders )+import GHC.Core.Type import GHC.Core.Multiplicity+import GHC.Core.Predicate import GHC.Core.TyCo.Rep( mkNakedFunTy )+import GHC.Core.TyCon( isTypeFamilyTyCon ) -import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike )-import GHC.Types.Id  ( Id, idName, idType, setInlinePragma+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Id  ( idName, idType, setInlinePragma                      , mkLocalId, realIdUnfolding ) import GHC.Types.Basic import GHC.Types.Name@@ -60,18 +73,19 @@ import GHC.Types.SrcLoc  import GHC.Builtin.Names( mkUnboundName )-import GHC.Unit.Module( getModule )+import GHC.Unit.Module( Module, getModule )  import GHC.Utils.Misc as Utils ( singleton ) import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Data.Bag import GHC.Data.Maybe( orElse, whenIsJust ) -import Data.Maybe( mapMaybe )-import qualified Data.List.NonEmpty as NE import Control.Monad( unless )-+import Data.Foldable ( toList )+import qualified Data.List.NonEmpty as NE+import Data.Maybe( mapMaybe )  {- -------------------------------------------------------------           Note [Overview of type signatures]@@ -273,7 +287,7 @@       HsWildCardTy _                 -> False       HsAppTy _ ty1 ty2              -> go ty1 && go ty2       HsAppKindTy _ ty ki            -> go ty && go ki-      HsFunTy _ w ty1 ty2            -> go ty1 && go ty2 && go (arrowToHsType w)+      HsFunTy _ w ty1 ty2            -> go ty1 && go ty2 && all go (multAnnToHsType w)       HsListTy _ ty                  -> go ty       HsTupleTy _ _ tys              -> gos tys       HsSumTy _ tys                  -> gos tys@@ -282,8 +296,6 @@       HsIParamTy _ _ ty              -> go ty       HsKindSig _ ty kind            -> go ty && go kind       HsDocTy _ ty _                 -> go ty-      HsBangTy _ _ ty                -> go ty-      HsRecTy _ flds                 -> gos $ map (cd_fld_type . unLoc) flds       HsExplicitListTy _ _ tys       -> gos tys       HsExplicitTupleTy _ _ tys      -> gos tys       HsForAllTy { hst_tele = tele@@ -567,8 +579,9 @@     prs = mapMaybe get_sig sigs      get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)-    get_sig sig@(L _ (SpecSig _ (L _ nm) _ _))   = Just (nm, add_arity nm sig)-    get_sig sig@(L _ (InlineSig _ (L _ nm) _))   = Just (nm, add_arity nm sig)+    get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig)+    get_sig sig@(L _ (SpecSigE nm _ _ _))      = Just (nm, add_arity nm sig)+    get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig)     get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig)     get_sig _ = Nothing @@ -584,6 +597,7 @@ addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn addInlinePragArity ar (L l (InlineSig x nm inl))  = L l (InlineSig x nm (add_inl_arity ar inl)) addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl))+addInlinePragArity ar (L l (SpecSigE n x e inl))  = L l (SpecSigE n x e (add_inl_arity ar inl)) addInlinePragArity _ sig = sig  add_inl_arity :: Arity -> InlinePragma -> InlinePragma@@ -650,13 +664,163 @@ *                                                                      * ************************************************************************ -Note [Handling SPECIALISE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Overview of SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The basic idea is this:     foo :: Num a => a -> b -> a-   {-# SPECIALISE foo :: Int -> b -> Int #-}+   foo = rhs+   {-# SPECIALISE foo :: Int -> b -> Int #-}   -- Old form+   {-# SPECIALISE foo @Float #-}               -- New form +Generally:+* Rename as usual+* Typecheck, attaching info to the ABExport record of the AbsBinds for foo+* Desugar by generating+   - a specialised binding $sfoo = rhs @Float+   - a rewrite rule like   RULE "USPEC foo" foo @Float = $sfoo++There are two major routes:++* Old form+  - Handled by `SpecSig` and `SpecPrag`+  - Deals with SPECIALISE pragmas have multiple signatures+       {-# SPECIALISE f :: Int -> Int, Float -> Float #-}+  - See Note [Handling old-form SPECIALISE pragmas]+  - Deprecated, to be removed in GHC 9.18 as per #25540.++* New form, described in GHC Proposal #493+  - Handled by `SpecSigE` and `SpecPragE`+  - Deals with SPECIALISE pragmas which may have value arguments+       {-# SPECIALISE f @Int 3 #-}+  - See Note [Handling new-form SPECIALISE pragmas]++Note [Handling new-form SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+New-form SPECIALISE pragmas are described by GHC Proposal #493.++The pragma takes the form of a function application, possibly with intervening+parens and type signatures, with a variable at the head:++    {-# SPECIALISE f1 @Int 3 #-}+    {-# SPECIALISE f2 :: Int -> Int #-}+    {-# SPECIALISE (f3 :: Int -> Int) 5 #-}++It may also have rule for-alls at the top, e.g.++    {-# SPECIALISE forall x xs. f4 (x:xs) #-}+    {-# SPECIALISE forall a. forall x xs. f5 @a @a (x:xs) #-}++See `GHC.Rename.Bind.checkSpecESigShape` for the shape-check.++Example:+  f :: forall a b. (Eq a, Eq b, Eq c) => a -> b -> c -> Bool -> blah+  {-# SPECIALISE forall x y. f (x::Int) y y True #-}+                 -- y::p++We want to generate:++  RULE forall @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p).+     f @Int @p @p d1 d2 d3 x y y True+        = $sf @p d2 x y+  $sf @p (d2::Eq p) (x::Int) (y::p)+     = let d1 = $fEqInt+           d3 = d2+       in <f-rhs> @p @p @Int (d1::Eq p) (d2::Eq p) (d3::Eq p) x y y True++Note that++* The `rule_bndrs`, over which the RULE is quantified, are all the variables+  free in the call to `f`, /ignoring/ all dictionary simplification.  Why?+  Because we want to make the rule maximally applicable; provided the types+  match, the dictionaries should match.++    rule_bndrs = @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p).++  Note that we have separate binders for `d1` and `d2` even though they are+  the same (Eq p) dictionary. Reason: we don't want to force them to be visibly+  equal at the call site.++* The `spec_bndrs`, which are lambda-bound in the specialised function `$sf`,+  are a subset of `rule_bndrs`.++    spec_bndrs = @p (d2::Eq p) (x::Int) (y::p)++* The `spec_const_binds` make up the difference between `rule_bndrs` and+  `spec_bndrs`.  They communicate the specialisation!+   If `spec_bndrs` = `rule_bndrs`, no specialisation has happened.++    spec_const_binds =  let d1 = $fEqInt+                            d3 = d2++This is done in three parts.++  A. Typechecker: `GHC.Tc.Gen.Sig.tcSpecPrag`++    (1) Typecheck the expression, capturing its constraints++    (2) Solve these constraints.  When doing so, switch on `tcsmFullySolveQCIs`;+        see wrinkle (NFS1) below.++    (3) Compute the constraints to quantify over, using `getRuleQuantCts` on+        the unsolved constraints returned by (2).++    (4) Emit the residual (non-solved, non-quantified) constraints, and wrap the+        expression in a let binding for those constraints.++    (5) Wrap the call in the combined evidence bindings from steps (2) and (4)++    (6) Store all the information in a 'SpecPragE' record, to be consumed+        by the desugarer.++  B. Zonker: `GHC.Tc.Zonk.Type.zonkLTcSpecPrags`++    The zonker does a little extra work to collect any free type variables+    of the LHS. See Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type.+    These weren't conveniently available earlier.++  C. Desugarer: `GHC.HsToCore.Binds.dsSpec`.++    See Note [Desugaring new-form SPECIALISE pragmas] in GHC.HsToCore.Binds for details,+    but in brief:++    (1) Simplify the expression. This is important because a type signature in+        the expression will have led to type/dictionary abstractions/applications.+        After simplification it should look like+            let <dict-binds> in f d1 d2 d3++    (2) `prepareSpecLHS` identifies the `spec_const_binds`, discards the other+        dictionary bindings, and decomposes the call.++    (3) Then we build the specialised function $sf, and concoct a RULE+        of the form:+           forall @a @b d1 d2 d3. f d1 d2 d3 = $sf d1 d2 d3++(NFS1) Consider+    f :: forall f a. (Ix a, forall x. Eq x => Eq (f x)) => a -> f a+    {-# SPECIALISE f :: forall f. (forall x. Eq x => Eq (f x)) => Int -> f Int #-}+  This SPECIALISE is treated like an expression with a type signature, so+  we instantiate the constraints, simplify them and re-generalise.  From the+  instantiation we get  [W] d :: (forall x. Eq a => Eq (f x))+  and we want to generalise over that.  We do not want to attempt to solve it+  and then get stuck, and emit an error message.  If we can't solve it, it is+  much, much better to leave it alone.++  We still need to simplify quantified constraints that can be /fully solved/+  from instances, otherwise we would never be able to specialise them+  away. Example: {-# SPECIALISE f @[] @a #-}.  So:++  * The constraint solver has a mode flag `tcsmFullySolveQCIs` that says+    "fully solve quantified constraint, or leave them alone+  * When simplifying constraints in a SPECIALISE pragma, we switch on this+    flag the `SpecPragE` case of `tcSpecPrag`.++  You might worry about the wasted work from failed attempts to fully-solve, but+  it is seldom repeated (because the constraint solver seldom iterates much).++Note [Handling old-form SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: this code path is deprecated, and is scheduled to be removed in GHC 9.18, as per #25440. We check that    (forall a b. Num a => a -> b -> a)       is more polymorphic than@@ -679,17 +843,22 @@     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) +    wrap_fn = /\ p q \(d1::Ix p)(d2:Ix q).+              let w1 = $fEqInt+                  w2 = $fIxPair d1 d2+              HOLE @Int @(p,q) (w1:Eq Int) (w2:Ix (p,q))+ From these we generate: -    Rule:       forall p, q, (dp:Ix p), (dq:Ix q).-                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq+    Rule:       forall p, q, (dInt::Eq Int), (dp:Ix p), (dq:Ix q).+                    f Int (p,q) dInt ($fIxPair dp dq) = f_spec p q dp dq -    Spec bind:  f_spec = wrap_fn <poly_rhs>+    Spec bind:  f_spec = wrap_fn[ <poly_rhs> ]  Note that    * The LHS of the rule may mention dictionary *expressions* (eg-    $dfIxPair dp dq), and that is essential because the dp, dq are+    $fIxPair dp dq), and that is essential because the dp, dq are     needed on the RHS.    * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it@@ -749,6 +918,27 @@    regardless of XXX.  It's sort of polymorphic in XXX.  This is    useful: we use the same wrapper to transform each of the class ops, as    well as the dict.  That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags++Note [SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~+There is no point in a SPECIALISE pragma for a non-overloaded function:+   reverse :: [a] -> [a]+   {-# SPECIALISE reverse :: [Int] -> [Int] #-}++But SPECIALISE INLINE *can* make sense for GADTS:+   data Arr e where+     ArrInt :: !Int -> ByteArray# -> Arr Int+     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)++   (!:) :: Arr e -> Int -> e+   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}+   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}+   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)+   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)++When (!:) is specialised it becomes non-recursive, and can usefully+be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE+for a non-overloaded function. -}  tcSpecPrags :: Id -> [LSig GhcRn]@@ -775,14 +965,14 @@ -------------- tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)--- See Note [Handling SPECIALISE pragmas]+-- See Note [Handling old-form SPECIALISE pragmas] -- -- The Name fun_name in the SpecSig may not be the same as that of the poly_id -- Example: SPECIALISE for a class method: the Name in the SpecSig is --          for the selector Id, but the poly_id is something like $cop -- However we want to use fun_name in the error message, since that is -- what the user wrote (#8537)-  = addErrCtxt (spec_ctxt prag) $+  = addErrCtxt (SpecPragmaCtxt prag) $     do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $                  TcRnNonOverloadedSpecialisePragma fun_name                     -- Note [SPECIALISE pragmas]@@ -792,26 +982,88 @@   where     name      = idName poly_id     poly_ty   = idType poly_id-    spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag)      tc_one hs_ty       = do { spec_ty <- tcHsSigType   (FunSigCtxt name NoRRC) hs_ty            ; wrap    <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty            ; return (SpecPrag poly_id wrap inl) } +tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl)+  -- For running commentary, see Note [Handling new-form SPECIALISE pragmas]+  = do { -- (1) Typecheck the expression, spec_e, capturing its constraints+         let skol_info_anon = SpecESkol nm+       ; traceTc "tcSpecPrag SpecSigE {" (ppr nm $$ ppr spec_e)+       ; skol_info <- mkSkolemInfo skol_info_anon+       ; (rhs_tclvl, spec_e_wanted, (rule_bndrs', (tc_spec_e, _rho)))+            <- tcRuleBndrs skol_info rule_bndrs $+               tcInferRho spec_e++         -- (2) Solve the resulting wanteds+       ; ev_binds_var <- newTcEvBinds+       ; spec_e_wanted <- setTcLevel rhs_tclvl            $+                          runTcSWithEvBinds ev_binds_var  $+                          setTcSMode (vanillaTcSMode { tcsmFullySolveQCIs = True }) $+                               -- tcsmFullySolveQCIs: see (NFS1)+                          solveWanteds spec_e_wanted+       ; spec_e_wanted <- liftZonkM $ zonkWC spec_e_wanted++         -- (3) Compute which constraints to quantify over, by looking+         --     at the unsolved constraints from (2)+       ; (quant_cands, residual_wc) <- getRuleQuantCts spec_e_wanted++         -- (4) Emit the residual constraints (i.e. ones that we have+         --     not solved in (2) nor quantified in (3)+         -- NB: use the same `ev_binds_var` as (2), so the bindings+         --     for (2) and (4) are combined+       ; let tv_bndrs = filter isTyVar rule_bndrs'+             qevs = map ctEvId (bagToList quant_cands)+       ; emitResidualConstraints rhs_tclvl skol_info_anon ev_binds_var+                                 emptyVarSet tv_bndrs qevs+                                 residual_wc++         -- (5) Wrap the call in the combined evidence bindings+         --     from steps (2) and (4)+       ; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) tc_spec_e++       ; ev_binds <- getTcEvBindsMap ev_binds_var++       ; traceTc "tcSpecPrag SpecSigE }" $+         vcat [ text "nm:" <+> ppr nm+              , text "rule_bndrs':" <+> ppr rule_bndrs'+              , text "qevs:" <+> ppr qevs+              , text "spec_e:" <+> ppr tc_spec_e+              , text "inl:" <+> ppr inl+              , text "spec_e_wanted:" <+> ppr spec_e_wanted+              , text "quant_cands:" <+> ppr quant_cands+              , text "residual_wc:" <+> ppr residual_wc+              , text (replicate 80 '-')+              , text "ev_binds_var:" <+> ppr ev_binds_var+              , text "ev_binds:" <+> ppr ev_binds+              ]++         -- (6) Store the results in a SpecPragE record, which will be+         -- zonked and then consumed by the desugarer.++       ; return [SpecPragE { spe_fn_nm = nm+                           , spe_fn_id = poly_id+                           , spe_bndrs = qevs ++ rule_bndrs' -- Dependency order+                                                             -- does not matter+                           , spe_call  = lhs_call+                           , spe_inl   = inl }] }+ tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)  -------------- tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper -- A simpler variant of tcSubType, used for SPECIALISE pragmas--- See Note [Handling SPECIALISE pragmas], wrinkle 1+-- See Note [Handling old-form SPECIALISE pragmas], wrinkle 1 tcSpecWrapper ctxt poly_ty spec_ty   = do { (sk_wrap, inst_wrap)                <- tcSkolemise Shallow ctxt spec_ty $ \spec_tau ->                   do { (inst_wrap, tau) <- topInstantiate orig poly_ty                      ; _ <- unifyType Nothing spec_tau tau                             -- Deliberately ignore the evidence-                            -- See Note [Handling SPECIALISE pragmas],+                            -- See Note [Handling old-form SPECIALISE pragmas],                             --   wrinkle (2)                      ; return inst_wrap }        ; return (sk_wrap <.> inst_wrap) }@@ -822,15 +1074,13 @@ tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] -- SPECIALISE pragmas for imported things tcImpPrags prags-  = do { this_mod <- getModule-       ; dflags <- getDynFlags+  = do { dflags <- getDynFlags+       ; traceTc "tcImpPrags1" (ppr prags)        ; if (not_specialising dflags) then             return []          else do-            { pss <- mapAndRecoverM (wrapLocMA tcImpSpec)-                     [L loc (name,prag)-                             | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags-                             , not (nameIsLocalOrFrom this_mod name) ]+            { this_mod <- getModule+            ; pss <- mapAndRecoverM (wrapLocMA (tcImpSpec this_mod)) prags             ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } }   where     -- Ignore SPECIALISE pragmas for imported things@@ -840,8 +1090,10 @@     not_specialising dflags =       not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags)) -tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]-tcImpSpec (name, prag)+tcImpSpec :: Module -> Sig GhcRn -> TcM [TcSpecPrag]+tcImpSpec this_mod prag+ | Just name <- is_spec_prag prag         -- It's a specialisation pragma+ , not (nameIsLocalOrFrom this_mod name)  -- The Id is imported  = do { id <- tcLookupId name       ; if hasSomeUnfolding (realIdUnfolding id)            -- See Note [SPECIALISE pragmas for imported Ids]@@ -849,6 +1101,12 @@         else do { let dia = TcRnSpecialiseNotVisible name                 ; addDiagnosticTc dia                 ; return [] } }+  | otherwise+  = return []+  where+    is_spec_prag (SpecSig _ (L _ nm) _ _) = Just nm+    is_spec_prag (SpecSigE nm _ _ _)      = Just nm+    is_spec_prag _                        = Nothing  {- Note [SPECIALISE pragmas for imported Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -867,3 +1125,568 @@ error message suggesting an INLINABLE pragma, which you can follow. That seems enough for now. -}+++{- *********************************************************************+*                                                                      *+                   Rules+*                                                                      *+************************************************************************++Note [Typechecking rules]+~~~~~~~~~~~~~~~~~~~~~~~~~+We *infer* the type of the LHS, and use that type to *check* the type of+the RHS.  That means that higher-rank rules work reasonably well. Here's+an example (test simplCore/should_compile/rule2.hs) produced by Roman:++   foo :: (forall m. m a -> m b) -> m a -> m b+   foo f = ...++   bar :: (forall m. m a -> m a) -> m a -> m a+   bar f = ...++   {-# RULES "foo/bar" foo = bar #-}++He wanted the rule to typecheck.++Note [TcLevel in type checking rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Bringing type variables into scope naturally bumps the TcLevel. Thus, we type+check the term-level binders in a bumped level, and we must accordingly bump+the level whenever these binders are in scope.++Note [Re-quantify type variables in rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example from #17710:++  foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b+  foo x = Proxy+  {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-}++Written out in more detail, the "foo" rewrite rule looks like this:++  forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0++Where b0 is a unification variable. Where should b0 be quantified? We have to+quantify it after k, since (b0 :: k). But generalization usually puts inferred+type variables (such as b0) at the /front/ of the telescope! This creates a+conflict.++One option is to simply throw an error, per the principles of+Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen+if we were generalising over a normal type signature. On the other hand, the+types in a rewrite rule aren't quite "normal", since the notions of specified+and inferred type variables aren't applicable.++A more permissive design (and the design that GHC uses) is to simply requantify+all of the type variables. That is, we would end up with this:++  forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b++It's a bit strange putting the generalized variable `b` after the user-written+variables `k` and `a`. But again, the notion of specificity is not relevant to+rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not+only makes "foo" typecheck, but it also makes the implementation simpler.++See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which+explains a very similar design when generalising over a type family instance+equation.+-}++tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc]+tcRules decls = mapM (wrapLocMA tcRuleDecls) decls++tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)+tcRuleDecls (HsRules { rds_ext = src+                     , rds_rules = decls })+   = do { maybe_tc_decls <- mapM (wrapLocMA tcRule) decls+        ; let tc_decls = [L loc rule | (L loc (Just rule)) <- maybe_tc_decls]+        ; return $ HsRules { rds_ext   = src+                           , rds_rules = tc_decls } }++tcRule :: RuleDecl GhcRn -> TcM (Maybe (RuleDecl GhcTc))+tcRule (HsRule { rd_ext  = ext+               , rd_name = rname@(L _ name)+               , rd_act  = act+               , rd_bndrs = bndrs+               , rd_lhs  = lhs+               , rd_rhs  = rhs })+  = addErrCtxt (RuleCtxt name)  $+    do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname)+       ; skol_info <- mkSkolemInfo (RuleSkol name)+        -- Note [Typechecking rules]+       ; (tc_lvl, lhs_wanted, stuff)+              <- tcRuleBndrs skol_info bndrs $+                 do { (lhs', rule_ty)    <- tcInferRho lhs+                    ; (rhs', rhs_wanted) <- captureConstraints $+                                            tcCheckMonoExpr rhs rule_ty+                    ; return (lhs', rule_ty, rhs', rhs_wanted) }++       ; let (bndrs', (lhs', rule_ty, rhs', rhs_wanted)) = stuff++       ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname+                                  , ppr lhs_wanted+                                  , ppr rhs_wanted ])++       ; (lhs_evs, residual_lhs_wanted, dont_default)+            <- simplifyRule name tc_lvl lhs_wanted rhs_wanted++       -- SimplifyRule Plan, step 4+       -- Now figure out what to quantify over+       -- c.f. GHC.Tc.Solver.simplifyInfer+       -- We quantify over any tyvars free in *either* the rule+       --  *or* the bound variables.  The latter is important.  Consider+       --      ss (x,(y,z)) = (x,z)+       --      RULE:  forall v. fst (ss v) = fst v+       -- The type of the rhs of the rule is just a, but v::(a,(b,c))+       --+       -- We also need to get the completely-unconstrained tyvars of+       -- the LHS, lest they otherwise get defaulted to Any; but we do that+       -- during zonking (see GHC.Tc.Zonk.Type.zonkRule)++       ; let tpl_ids = lhs_evs ++ filter isId bndrs'++       -- See Note [Re-quantify type variables in rules]+       ; dvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)+       ; let weed_out = (`dVarSetMinusVarSet` dont_default)+             weeded_dvs = weedOutCandidates weed_out dvs+       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars weeded_dvs+       ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname+                                , text "dvs:" <+> ppr dvs+                                , text "weeded_dvs:" <+> ppr weeded_dvs+                                , text "dont_default:" <+> ppr dont_default+                                , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted+                                , text "qtkvs:" <+> ppr qtkvs+                                , text "rule_ty:" <+> ppr rule_ty+                                , text "bndrs:" <+> ppr bndrs+                                , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids)+                                , text "tpl_id info:" <+>+                                  vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]+                  ])++       -- /Temporarily/ deal with the fact that we previously accepted+       -- rules that quantify over certain equality constraints.+       --+       -- See Note [Quantifying over equalities in RULES].+       ; case allPreviouslyQuantifiableEqualities residual_lhs_wanted of {+           Just cts | not (insolubleWC rhs_wanted)+                    -> do { addDiagnostic $ TcRnRuleLhsEqualities name lhs cts+                          ; return Nothing } ;+           _  ->++   do  { -- SimplifyRule Plan, step 5+       -- Simplify the LHS and RHS constraints:+       -- For the LHS constraints we must solve the remaining constraints+       -- (a) so that we report insoluble ones+       -- (b) so that we bind any soluble ones+         (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs+                                         lhs_evs residual_lhs_wanted+       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs+                                         lhs_evs rhs_wanted++       ; emitImplications (lhs_implic `unionBags` rhs_implic)++       ; return $ Just $+         HsRule { rd_ext   = ext+                , rd_name  = rname+                , rd_act   = act+                , rd_bndrs = bndrs { rb_ext = qtkvs ++ tpl_ids }+                , rd_lhs   = mkHsDictLet lhs_binds lhs'+                , rd_rhs   = mkHsDictLet rhs_binds rhs' } } } }++{- ********************************************************************************+*                                                                                 *+                      tcRuleBndrs+*                                                                                 *+******************************************************************************** -}++tcRuleBndrs :: SkolemInfo -> RuleBndrs GhcRn+            -> TcM a      -- Typecheck this with the rule binders in scope+            -> TcM (TcLevel, WantedConstraints, ([Var], a))+                        -- The [Var] are the explicitly-quantified variables,+                        -- both type variables and term variables+tcRuleBndrs skol_info (RuleBndrs { rb_tyvs = mb_tv_bndrs, rb_tmvs = tm_bndrs })+            thing_inside+  = pushLevelAndCaptureConstraints $+    case mb_tv_bndrs of+      Nothing       ->  go_tms tm_bndrs thing_inside+      Just tv_bndrs -> do { (bndrs1, (bndrs2, res)) <- go_tvs tv_bndrs $+                                                       go_tms tm_bndrs $+                                                       thing_inside+                          ; return (binderVars bndrs1 ++ bndrs2, res) }+  where+    --------------+    go_tvs tvs thing_inside = bindExplicitTKBndrs_Skol skol_info tvs thing_inside++    --------------+    go_tms [] thing_inside+      = do { res <- thing_inside; return ([], res) }+    go_tms (L _ (RuleBndr _ (L _ name)) : rule_bndrs) thing_inside+      = do  { ty <- newOpenFlexiTyVarTy+            ; let bndr_id = mkLocalId name ManyTy ty+            ; (bndrs, res) <- tcExtendIdEnv [bndr_id] $+                              go_tms rule_bndrs thing_inside+            ; return (bndr_id : bndrs, res) }++    go_tms (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) thing_inside+      --  e.g         x :: a->a+      --  The tyvar 'a' is brought into scope first, just as if you'd written+      --              a::*, x :: a->a+      --  If there's an explicit forall, the renamer would have already reported an+      --   error for each out-of-scope type variable used+      = do  { (_ , tv_prs, id_ty) <- tcRuleBndrSig name skol_info rn_ty+            ; let bndr_id  = mkLocalId name ManyTy id_ty+                     -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType++                     -- The type variables scope over subsequent bindings; yuk+            ; (bndrs, res) <- tcExtendNameTyVarEnv tv_prs $+                              tcExtendIdEnv [bndr_id]     $+                              go_tms rule_bndrs thing_inside+            ; return (map snd tv_prs ++ bndr_id : bndrs, res) }+++{-+*********************************************************************************+*                                                                                 *+              Constraint simplification for rules+*                                                                                 *+***********************************************************************************++Note [The SimplifyRule Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example.  Consider the following left-hand side of a rule+        f (x == y) (y > z) = ...+If we typecheck this expression we get constraints+        d1 :: Ord a, d2 :: Eq a+We do NOT want to "simplify" to the LHS+        forall x::a, y::a, z::a, d1::Ord a.+          f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...+Instead we want+        forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.+          f ((==) d2 x y) ((>) d1 y z) = ...++Here is another example:+        fromIntegral :: (Integral a, Num b) => a -> b+        {-# RULES "foo"  fromIntegral = id :: Int -> Int #-}+In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But+we *dont* want to get+        forall dIntegralInt.+           fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int+because the scsel will mess up RULE matching.  Instead we want+        forall dIntegralInt, dNumInt.+          fromIntegral Int Int dIntegralInt dNumInt = id Int++Even if we have+        g (x == y) (y == z) = ..+where the two dictionaries are *identical*, we do NOT WANT+        forall x::a, y::a, z::a, d1::Eq a+          f ((==) d1 x y) ((>) d1 y z) = ...+because that will only match if the dict args are (visibly) equal.+Instead we want to quantify over the dictionaries separately.++In short, simplifyRuleLhs must *only* squash equalities, leaving+all dicts unchanged, with absolutely no sharing.++Also note that we can't solve the LHS constraints in isolation:+Example   foo :: Ord a => a -> a+          foo_spec :: Int -> Int+          {-# RULE "foo"  foo = foo_spec #-}+Here, it's the RHS that fixes the type variable++HOWEVER, under a nested implication things are different+Consider+  f :: (forall a. Eq a => a->a) -> Bool -> ...+  {-# RULES "foo" forall (v::forall b. Eq b => b->b).+       f b True = ...+    #-}+Here we *must* solve the wanted (Eq a) from the given (Eq a)+resulting from skolemising the argument type of g.  So we+revert to SimplCheck when going under an implication.+++--------- So the SimplifyRule Plan is this -----------------------++* Step 0: typecheck the LHS and RHS to get constraints from each++* Step 1: Simplify the LHS and RHS constraints all together in one bag,+          but /discarding/ the simplified constraints. We do this only+          to discover all unification equalities.++* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take+          advantage of those unifications++* Step 3: Partition the LHS constraints into the ones we will+          quantify over, and the others.+          See Note [RULE quantification over equalities]++* Step 4: Decide on the type variables to quantify over++* Step 5: Simplify the LHS and RHS constraints separately, using the+          quantified constraints as givens++Note [Solve order for RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In step 1 above, we need to be a bit careful about solve order.+Consider+   f :: Int -> T Int+   type instance T Int = Bool++   RULE f 3 = True++From the RULE we get+   lhs-constraints:  T Int ~ alpha+   rhs-constraints:  Bool ~ alpha+where 'alpha' is the type that connects the two.  If we glom them+all together, and solve the RHS constraint first, we might solve+with alpha := Bool.  But then we'd end up with a RULE like++    RULE: f 3 |> (co :: T Int ~ Bool) = True++which is terrible.  We want++    RULE: f 3 = True |> (sym co :: Bool ~ T Int)++So we are careful to solve the LHS constraints first, and *then* the+RHS constraints.  Actually much of this is done by the on-the-fly+constraint solving, so the same order must be observed in+tcRule.++Note [RULE quantification over equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At the moment a RULE never quantifies over an equality; see `rule_quant_ct`+in `getRuleQuantCts`.  Why not?++ * It's not clear why we would want to do so (see Historical Note+   below)++ * We do not want to quantify over insoluble equalities (Int ~ Bool)+    (a) because we prefer to report a LHS type error+    (b) because if such things end up in 'givens' we get a bogus+        "inaccessible code" error++ * Matching on coercions is Deeply Suspicious.  We don't want to generate a+   RULE like+         forall a (co :: F a ~ Int).+                foo (x |> Sym co) = ...co...+   because matching on that template, to bind `co`, would require us to+   match on the /structure/ of a coercion, which we must never do.+   See GHC.Core.Rules Note [Casts in the template]++ * Equality constraints are unboxed, and that leads to complications+   For example equality constraints from the LHS will emit coercion hole+   Wanteds.  These don't have a name, so we can't quantify over them directly.+   Instead, in `getRuleQuantCts`, we'd have to invent a new EvVar for the+   coercion, fill the hole with the invented EvVar, and then quantify over the+   EvVar. Here is old code from `mk_one`+         do { ev_id <- newEvVar pred+            ; fillCoercionHole hole (mkCoVarCo ev_id)+            ; return ev_id }+    But that led to new complications becuase of the side effect on the coercion+    hole. Much easier just to side-step the issue entirely by not quantifying over+    equalities.++Historical Note:+  Back in 2012 (5aa1ae24567) we started quantifying over some equality+  constraints, saying+   * But we do want to quantify over things like (a ~ F b),+     where F is a type function.+  It is not clear /why/ we did so, and we don't do so any longer.+End of historical note.++Note [Simplify cloned constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At this stage, we're simplifying constraints only for insolubility+and for unification. Note that all the evidence is quickly discarded.+We use a clone of the real constraint. If we don't do this,+then RHS coercion-hole constraints get filled in, only to get filled+in *again* when solving the implications emitted from tcRule. That's+terrible, so we avoid the problem by cloning the constraints.++-}++simplifyRule :: RuleName+             -> TcLevel                 -- Level at which to solve the constraints+             -> WantedConstraints       -- Constraints from LHS+             -> WantedConstraints       -- Constraints from RHS+             -> TcM ( [EvVar]               -- Quantify over these LHS vars+                    , WantedConstraints     -- Residual un-quantified LHS constraints+                    , TcTyVarSet )          -- Don't default these+-- See Note [The SimplifyRule Plan]+-- NB: This consumes all simple constraints on the LHS, but not+-- any LHS implication constraints.+simplifyRule name tc_lvl lhs_wanted rhs_wanted+  = do {+       -- Note [The SimplifyRule Plan] step 1+       -- First solve the LHS and *then* solve the RHS+       -- Crucially, this performs unifications+       -- Why clone?  See Note [Simplify cloned constraints]+       ; lhs_clone <- cloneWC lhs_wanted+       ; rhs_clone <- cloneWC rhs_wanted+       ; (dont_default, _)+            <- setTcLevel tc_lvl $+               runTcS            $+               do { lhs_wc  <- solveWanteds lhs_clone+                  ; _rhs_wc <- solveWanteds rhs_clone+                        -- Why do them separately?+                        -- See Note [Solve order for RULES]++                  ; let dont_default = nonDefaultableTyVarsOfWC lhs_wc+                        -- If lhs_wanteds has+                        --   (a[sk] :: TYPE rr[sk]) ~ (b0[tau] :: TYPE r0[conc])+                        -- we want r0 to be non-defaultable;+                        -- see nonDefaultableTyVarsOfWC.  Simplest way to get+                        -- this is to look at the post-simplified lhs_wc, which+                        -- will contain (rr[sk] ~ r0[conc)].  An example is in+                        -- test rep-poly/RepPolyRule1+                  ; return dont_default }++       -- Note [The SimplifyRule Plan] step 2+       ; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted++       -- Note [The SimplifyRule Plan] step 3+       ; (quant_cts, residual_lhs_wanted) <- getRuleQuantCts lhs_wanted+       ; let quant_evs = map ctEvId (bagToList quant_cts)++       ; traceTc "simplifyRule" $+         vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)+              , text "lhs_wanted" <+> ppr lhs_wanted+              , text "rhs_wanted" <+> ppr rhs_wanted+              , text "quant_cts" <+> ppr quant_evs+              , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted+              , text "dont_default" <+> ppr dont_default+              ]++       ; return (quant_evs, residual_lhs_wanted, dont_default) }++getRuleQuantCts :: WantedConstraints -> TcM (Cts, WantedConstraints)+-- Extract all the constraints that we can quantify over,+--   also returning the depleted WantedConstraints+--+-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,+--   and attempt to solve them from the quantified constraints.  Instead+--   we /partition/ the WantedConstraints into ones to quantify and ones+--   we can't quantify.  We could use approximateWC instead, and leave+--   `wanted` unchanged; but then we'd have to clone fresh binders and+--   generate silly identity bindings.  Seems more direct to do this.+--   Probably not a big deal wither way.+--+-- NB: we must look inside implications, because with+--     -fdefer-type-errors we generate implications rather eagerly;+--     see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732.++getRuleQuantCts wc+  = return $ float_wc emptyVarSet wc+  where+    float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)+    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })+      = ( simple_yes `andCts` implic_yes+        , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs })+     where+        (simple_yes, simple_no)  = partitionBag (rule_quant_ct skol_tvs) simples+        (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)  emptyBag implics++    float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication)+    float_implic skol_tvs yes1 imp+      = (yes1 `andCts` yes2, imp { ic_wanted = no })+      where+        (yes2, no) = float_wc new_skol_tvs (ic_wanted imp)+        new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp++    rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool+    rule_quant_ct skol_tvs ct+      | insolubleWantedCt ct+      = False+      | otherwise+      = case classifyPredType (ctPred ct) of+           EqPred {} -> False  -- Note [RULE quantification over equalities]+           _         -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs++{- Note [Quantifying over equalities in RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Up until version 9.12 (inclusive), GHC would happily quantify over certain Wanted+equalities in the LHS of a RULE. This was incorrect behaviour that led to a RULE+that would never fire, so GHC 9.14 and above no longer allow such RULES.+However, instead of throwing an error, GHC will /temporarily/ emit a warning+and drop the rule instead, in order to ease migration for library maintainers+(NB: this warning is not emitted when the RHS constraints are insoluble; in that+case we simply report those constraints as errors instead).+This warning is scheduled to be turned into an error, and the warning flag+removed (becoming a normal typechecker error), starting from version 9.18.++The function 'allPreviouslyQuantifiableEqualities' computes the equality+constraints that previous (<= 9.12) versions of GHC accepted quantifying over.+++  Example (test case 'RuleEqs', extracted from the 'mono-traversable' library):++    type family Element mono+    type instance Element [a] = a++    class MonoFoldable mono where+        otoList :: mono -> [Element mono]+    instance MonoFoldable [a] where+        otoList = id++    ointercalate :: (MonoFoldable mono, Monoid (Element mono))+                 => Element mono -> mono -> Element mono+    {-# RULES "ointercalate list" forall x. ointercalate x = Data.List.intercalate x . otoList #-}++  Now, because Data.List.intercalate has the type signature++    forall a. [a] -> [[a]] -> [a]++  typechecking the LHS of this rule would give rise to the Wanted equality++    [W] Element mono ~ [a]++  Due to the type family, GHC 9.12 and below accepted to quantify over this+  equality, which would lead to a rule LHS template of the form:++    forall (@mono) (@a)+           ($dMonoFoldable :: MonoFoldable mono)+           ($dMonoid :: Monoid (Element mono))+           (co :: [a] ~ Element mono)+           (x :: [a]).+      ointercalate @mono $dMonoFoldable $dMonoid+        (x `cast` (Sub co))++  Matching against this template would match on the structure of a coercion,+  which goes against Note [Casts in the template] in GHC.Core.Rules.+  In practice, this meant that this RULE would never fire.+-}++-- | Computes all equality constraints that GHC doesn't accept, but previously+-- did accept (until GHC 9.12 (included)), when deciding what to quantify over+-- in the LHS of a RULE.+--+-- See Note [Quantifying over equalities in RULES].+allPreviouslyQuantifiableEqualities :: WantedConstraints -> Maybe (NE.NonEmpty Ct)+allPreviouslyQuantifiableEqualities wc = go emptyVarSet wc+  where+    go :: TyVarSet -> WantedConstraints -> Maybe (NE.NonEmpty Ct)+    go skol_tvs (WC { wc_simple = simples, wc_impl = implics })+      = do { cts1 <-       mapM (go_simple skol_tvs) simples+           ; cts2 <- concatMapM (go_implic skol_tvs) implics+           ; NE.nonEmpty $ toList cts1 ++ toList cts2 }++    go_simple :: TyVarSet -> Ct -> Maybe Ct+    go_simple skol_tvs ct+      | not (tyCoVarsOfCt ct `disjointVarSet` skol_tvs)+      = Nothing+      | EqPred _ t1 t2 <- classifyPredType (ctPred ct), ok_eq t1 t2+      = Just ct+      | otherwise+      = Nothing++    go_implic :: TyVarSet -> Implication -> Maybe [Ct]+    go_implic skol_tvs (Implic { ic_skols = skols, ic_wanted = wc })+      = fmap toList $ go (skol_tvs `extendVarSetList` skols) wc++    ok_eq t1 t2+       | t1 `tcEqType` t2 = False+       | otherwise        = is_fun_app t1 || is_fun_app t2++    is_fun_app ty   -- ty is of form (F tys) where F is a type function+      = case tyConAppTyCon_maybe ty of+          Just tc -> isTypeFamilyTyCon tc+          Nothing -> False
compiler/GHC/Tc/Gen/Splice.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables    #-} {-# LANGUAGE TupleSections          #-} {-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE DataKinds              #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -89,7 +90,7 @@ import GHCi.RemoteTypes import GHC.Runtime.Interpreter -import GHC.Rename.Splice( traceSplice, SpliceInfo(..))+import GHC.Rename.Splice( traceSplice, SpliceInfo(..) ) import GHC.Rename.Expr import GHC.Rename.Env import GHC.Rename.Fixity ( lookupFixityRn_help )@@ -124,7 +125,7 @@ import GHC.Unit.Finder import GHC.Unit.Module import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Deps+import GHC.Iface.Syntax  import GHC.Utils.Misc import GHC.Utils.Panic as Panic@@ -137,7 +138,9 @@  import GHC.Data.FastString import GHC.Data.Maybe( MaybeErr(..) )+import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet+import qualified GHC.LanguageExtensions as LangExt  -- THSyntax gives access to internal functions and data types import qualified GHC.Boot.TH.Syntax as TH@@ -145,8 +148,13 @@  #if defined(HAVE_INTERNAL_INTERPRETER) import Unsafe.Coerce    ( unsafeCoerce )+#if !MIN_VERSION_base(4,22,0) import GHC.Desugar ( AnnotationWrapper(..) )+#else+import GHC.Internal.Desugar ( AnnotationWrapper(..) ) #endif+import Control.DeepSeq+#endif  import Control.Monad import Data.Binary@@ -170,27 +178,27 @@ {- Note [Template Haskell state diagram] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here are the ThStages, s, their corresponding level numbers-(the result of (thLevel s)), and their state transitions.+Here are the ThLevels, their corresponding level numbers+(the result of (thLevelIndex s)), and their state transitions. The top level of the program is stage Comp:       Start here          |          V-      -----------     $      ------------   $-      |  Comp   | ---------> |  Splice  | -----|-      |   1     |            |    0     | <----|-      -----------            ------------+      -----------     $      ------------   $    -----------------+      |  Comp   | ---------> |  Splice  | -----> | Splice Splice |+      |   0     |            |    -1    | <----  |     -2        |+      -----------            ------------  [||]  -----------------         ^     |                ^      |       $ |     | [||]         $ |      | [||]         |     v                |      v    --------------          ----------------    | Brack Comp |          | Brack Splice |-   |     2      |          |      1       |+   |     1      |          |      0       |    --------------          ----------------  * Normal top-level declarations start in state Comp-       (which has level 1).+       (which has level 0).   Annotations start in state Splice, since they are        treated very like a splice (only without a '$') @@ -198,31 +206,30 @@   will be *run at compile time*, with the result replacing   the splice -* The original paper used level -1 instead of 0, etc.- * The original paper did not allow a splice within a   splice, but there is no reason not to. This is the   $ transition in the top right.  Note [Template Haskell levels] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* Imported things are impLevel (= 0)+* The level checks are implemented for terms in `checkThLocalName` -* However things at level 0 are not *necessarily* imported.-      eg  $( \b -> ... )   here b is bound at level 0+* Imported things are level 0 +* Top-level things are level 0+ * In GHCi, variables bound by a previous command are treated-  as impLevel, because we have bytecode for them.+  as imported, because we have bytecode for them.  * Variables are bound at the "current level" -* The current level starts off at outerLevel (= 1)+* The current level starts off at 0  * The level is decremented by splicing $(..)                incremented by brackets [| |]                incremented by name-quoting 'f -* When a variable is used, checkWellStaged compares+* When a variable is used, checkThLocalName compares         bind:  binding level, and         use:   current level at usage site @@ -233,16 +240,18 @@         bind = use      Always OK (bound same stage as used)                         [| \x -> $(f [| x |]) |] -        bind < use      Inside brackets, it depends-                        Inside splice, OK-                        Inside neither, OK+        bind < use      Inside brackets, it depends on what cross stage+                        persistence rules are used.    For (bind < use) inside brackets, there are three cases:-    - Imported things   OK      f = [| map |]-    - Top-level things  OK      g = [| f |]+    - Imported things (if ImplicitStagePersistence is enabled)   OK      f = [| map |]+    - Top-level things (if ImplicitStagePersistence is enabled)  OK      g = [| f |]     - Non-top-level     Only if there is a liftable instance                                 h = \(x:Int) -> [| x |] +  If ExplicitLevelImports is used, then imports can bring identifiers into scope+  at non-zero levels.+   To track top-level-ness we use the ThBindEnv in TcLclEnv    For example:@@ -380,7 +389,7 @@ returned together in a `QuoteWrapper` and then passed along to two further places during compilation: -1. Typechecking nested splices (immediately in tcPendingSplice)+1. Typechecking nested splices (immediately in tcUntypedSplice) 2. Desugaring quotations (see GHC.HsToCore.Quote)  `tcPendingSplice` takes the `m` type variable as an argument and@@ -407,7 +416,7 @@ Note [Lifecycle of an untyped splice, and PendingRnSplice] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Untyped splices $(f x) and quasiquotes [p| stuff |] have the following-life cycle. Remember, quasi-quotes are very like splices; see Note [Quasi-quote overview]).+life cycle. Quasi-quotes are very like splices; see Note [Quasi-quote overview]).  The type structure is @@ -417,13 +426,14 @@   data HsUntypedSplice p     = HsUntypedSpliceExpr (XUntypedSpliceExpr p) (LHsExpr p)     | HsQuasiQuote (XQuasiQuote p) (IdP id) (XRec p FastString)+    | XXUntypedSplice (XUntypedSplice p) -Remember that untyped splices can occur in expressions, patterns,+Untyped splices can occur in expressions, patterns, types, and declarations.  So we have a HsUntypedSplice data constructor in all four of these types.  Untyped splices never occur in (HsExpr GhcTc), and similarly-patterns etc. So we have+patterns etc, because the body of a untyped quotation is not typechecked. So we have     type instance XUntypedSplice GhcTc = DataConCantHappen @@ -445,7 +455,7 @@  RENAMER (rnUntypedBracket): -* Set the ThStage to (Brack s (RnPendingUntyped ps_var))+* Set the ThLevel to (Brack s (RnPendingUntyped ps_var))  * Rename the body @@ -462,9 +472,9 @@  The result is     HsUntypedBracket-        [PendingRnSplice UntypedExpSplice spn (g x  :: LHsExpr GHcRn)]+        [PendingRnSplice spn (HsUntypedSpliceExpr UntypedExpSplice (g x  :: LHsExpr GHcRn))]         (HsApp (HsVar f) (HsUntypedSplice (HsUntypedSpliceNested spn)-                                          (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn))))+                                          (HsUntypedSpliceExpr UntypedExpSplice (g x :: LHsExpr GhcRn))))  Note that a nested splice, such as the `$(g x)` now appears twice:   - In the PendingRnSplice: this is the version that will later be typechecked@@ -477,14 +487,13 @@    [| let $e0 in (f :: $e1) $e2 (\ $e -> body ) |] + 1  Here $e0 is a declaration splice, $e1 is a type splice, $e2 is an-expression splice, and $e3 is a pattern splice.  The `PendingRnSplice`-keeps track of which is which through its `UntypedSpliceFlavour`-field.+expression splice, and $e3 is a pattern splice. The `SpliceFlavour` is stored+in the extension field of HsUntypedSpliceExpr.  TYPECHECKER (tcUntypedBracket): see also Note [Typechecking Overloaded Quotes] -* Typecheck the [PendingRnSplice] individually, to give [PendingTcSplice]-  So PendingTcSplice is used for both typed and untyped splices.+* Typecheck the [PendingRnSplice] individually, to give [PendingTcSplice].+  PendingTcSplice is used for both typed and untyped splices.  * Ignore the body of the bracket; just check that the context   expects a bracket of that type (e.g. a [p| pat |] bracket should@@ -497,7 +506,7 @@         (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x  :: LHsExpr GHcTc)]                      , hsb_quote = HsApp (HsVar f)                                          (HsUntypedSplice (HsUntypedSpliceNested spn)-                                            (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn)))+                                            (HsUntypedSpliceExpr UntypedExpSplice (g x :: LHsExpr GhcRn)))                      })         (XQuote noExtField) @@ -505,7 +514,20 @@ have type (HsQuote GhcTc) is stubbed off with (XQuote noExtField). The payload is now in the hsb_quote field of the HsBracketTc. +-------------------------------------+Implicit lifting+------------------------------------- +When a variable is bound at level n and used at level n+1, the renamer will decide,+in `checkThLocalNameWithLift`, to implicitly lift this variable to level n+1.+This is done by replacing the occurrence of `x` with `$(lift x)`.+This decision is then stored in the extension points 'XXUntypedSplice'/'XXTypedSplice'.+When we come to typechecking these splices, the typechecker will emit the appropriate+'Lift' constraint, with a `ImplicitLiftOrigin` `CtOrigin`. If we fail to solve this constraint,+a level error is reported to the user.+++ ------------------------------------- Top-level untyped splices/quasiquotes -------------------------------------@@ -537,8 +559,8 @@ Nested, typed splices ---------------------- When we typecheck a /typed/ bracket, we lift nested splices out as-`PendingTcSplice`, very similar to Note [PendingRnSplice]. Again, the-splice needs a SplicePointName, for the desguarer to use to connect+`PendingTcSplice`, very similar to Note [Pending Splices]. Again, the+splice needs a SplicePointName, for the desugarer to use to connect the splice expression with the point in the syntax tree where it is used.  Example:      [||  f $$(g 2)||]@@ -546,20 +568,20 @@ Parser: this is parsed as      HsTypedBracket _ (HsApp (HsVar "f")-                            (HsTypedSplice _ (g 2 :: LHsExpr GhcPs)))+                            (HsTypedSplice _ (HsTypedSpliceExpr _ (g 2 :: LHsExpr GhcPs))))  RENAMER (rnTypedSplice): the renamer adds a SplicePointName, spn:      HsTypedBracket _ (HsApp (HsVar "f")-                            (HsTypedSplice spn (g x :: LHsExpr GhcRn)))+                            (HsTypedSplice (HsTypedSpliceNested spn) (HsTypedSpliceExpr _ (g x :: LHsExpr GhcRn))))  TYPECHECKER (tcTypedBracket): -* Set the ThStage to (Brack s (TcPending ps_var lie_var))+* Set the ThLevel to (Brack s (TcPending ps_var lie_var quote_wrapper)) -* Typecheck the body, and keep the elaborated result (despite never using it!)+* Typecheck the body, and keep the elaborated result (despite never using it!, todo: it should be stored in the AST) -* Nested splices (which must be typed) are typechecked by tcNestedSplice, and+* Nested splices (which must be typed) are typechecked by tcTypedSplice, and   the results accumulated in ps_var; their constraints accumulate in lie_var  * Result is a HsTypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) tc_brack@@ -651,7 +673,7 @@ tcTypedBracket    :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcUntypedBracket  :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType                   -> TcM (HsExpr GhcTc)-tcTypedSplice     :: Name -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+tcTypedSplice     :: HsTypedSpliceResult -> HsTypedSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)  getUntypedSpliceBody :: HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn) runAnnotation        :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation@@ -666,9 +688,9 @@  -- See Note [How brackets and nested splices are handled] tcTypedBracket rn_expr expr res_ty-  = addErrCtxt (quotationCtxtDoc expr) $-    do { cur_stage <- getStage-       ; ps_ref <- newMutVar []+  = addErrCtxt (TypedTHBracketCtxt expr) $+    do { cur_lvl <- getThLevel+       ; ps_var <- newMutVar []        ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices                                        -- should get thrown into the constraint set                                        -- from outside the bracket@@ -680,18 +702,19 @@        -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring        -- brackets.        ; let wrapper = QuoteWrapper ev_var m_var+        -- Typecheck expr to make sure it is valid.        -- The typechecked expression won't be used, so we just discard it        --   (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr)        -- We'll typecheck it again when we splice it in somewhere-       ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $+       ; (tc_expr, expr_ty) <- setThLevel (Brack cur_lvl (TcPending ps_var lie_var wrapper)) $                                 tcScalingUsage ManyTy $                                 -- Scale by Many, TH lifting is currently nonlinear (#18465)                                 tcInferRhoNC expr                                 -- NC for no context; tcBracket does that        ; let rep = getRuntimeRep expr_ty-       ; meta_ty <- tcTExpTy m_var expr_ty-       ; ps' <- readMutVar ps_ref+       ; meta_ty <- tcCodeTy m_var expr_ty+       ; ps' <- readMutVar ps_var        ; codeco <- tcLookupId unsafeCodeCoerceName        ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName        ; let brack_tc = HsBracketTc { hsb_quote = ExpBr noExtField expr, hsb_ty = bracket_ty@@ -718,8 +741,8 @@        -- Match the expected type with the type of all the internal        -- splices. They might have further constrained types and if they do        -- 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+       ; ps' <- case brack_info of+                  Just q -> mapM (tc_nested_splice q) ps                   Nothing -> assert (null ps) $ return []         -- Notice that we don't attempt to typecheck the body@@ -735,6 +758,9 @@             expected_type res_ty         }+    where+      tc_nested_splice :: QuoteWrapper -> PendingRnSplice -> TcM PendingTcSplice+      tc_nested_splice q (PendingRnSplice splice_name expr) = tcUntypedSplice q splice_name expr  -- | A type variable with kind * -> * named "m" mkMetaTyVar :: TcM TyVar@@ -777,43 +803,119 @@     (PatBr {})  -> mkTy patTyConName  -- Result type is m Pat     (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL" ++untypedSpliceResultType :: UntypedSpliceFlavour -> TcType -> TcM TcType+untypedSpliceResultType flavour meta_ty = do+  sp_ty <- tcMetaTy sp_ty_name+  return $ mkAppTy meta_ty sp_ty+  where+    sp_ty_name = case flavour of+      UntypedExpSplice  -> expTyConName+      UntypedPatSplice  -> patTyConName+      UntypedTypeSplice -> typeTyConName+      UntypedDeclSplice -> decsTyConName+ --------------- -- | Typechecking a pending splice from a untyped bracket-tcPendingSplice :: TcType -- Metavariable for the expected overall type of the+-- TODO: Should return HsUntypedSplice GhcTc, and the desugarer should+--       construct the relevant CoreExpr rather than performing desugaring here.+tcUntypedSplice :: QuoteWrapper -- Metavariable for the expected overall type of the                           -- quotation.-                -> PendingRnSplice+                -> SplicePointName+                -> HsUntypedSplice GhcRn                 -> TcM PendingTcSplice-tcPendingSplice m_var (PendingRnSplice flavour splice_name expr)+tcUntypedSplice (QuoteWrapper _ m_var) splice_name (HsUntypedSpliceExpr (HsUserSpliceExt flavour) expr)   -- See Note [Typechecking Overloaded Quotes]-  = do { meta_ty <- tcMetaTy meta_ty_name-         -- Expected type of splice, e.g. m Exp-       ; let expected_type = mkAppTy m_var meta_ty+  = do { expected_type <- untypedSpliceResultType flavour m_var        ; expr' <- tcScalingUsage ManyTy $ tcCheckPolyExpr expr expected_type                   -- Scale by Many, TH lifting is currently nonlinear (#18465)        ; return (PendingTcSplice splice_name expr') }-  where-     meta_ty_name = case flavour of-                       UntypedExpSplice  -> expTyConName-                       UntypedPatSplice  -> patTyConName-                       UntypedTypeSplice -> typeTyConName-                       UntypedDeclSplice -> decsTyConName+tcUntypedSplice (QuoteWrapper _ m_var) splice_name (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter s) = do+   -- 1. Check that the quoter is of type 'QuasiQuoter'+   qq_type <- mkTyConTy <$> tcLookupTyCon quasiQuoterTyConName+   quoter' <- setSrcSpan (getLocA quoter) $ tcCheckId (unLoc quoter) (Check qq_type) +   -- 2. Check that the quasi-quote has type Q Exp/Q Pat/Q Dec/Q Decs (as appropriate)+   qTy <- mkTyConTy <$> tcLookupTyCon qTyConName+   quote_ty <- untypedSpliceResultType flavour m_var+   splice_ty <- untypedSpliceResultType flavour qTy+   res_co <- unifyInvisibleType splice_ty quote_ty++   -- 3. Lookup the relevant field selector from QuasiQuoter+   sel <- tcLookupId qq_sel_name++   -- 4. Apply the selector to the quasi-quoter+   let expr' = mkLHsWrapCo res_co $+                nlHsApp (nlHsApp (nlHsVar sel) (noLocA quoter')) (nlHsLit (mkHsStringFS (unLoc s)))++   return (PendingTcSplice splice_name expr')+   where+    qq_sel_name = case flavour of+      UntypedExpSplice  -> quoteExpName+      UntypedPatSplice  -> quotePatName+      UntypedTypeSplice -> quoteTypeName+      UntypedDeclSplice -> quoteDecName++  -- Identifiers that are lifted implicitly, such as 'x' in+  -- E.g. \x -> [| h x |]+  -- We must behave as if the reference to x was+  --      h $(lift x)+  -- We use 'x' itself as the SplicePointName, used by+  -- the desugarer to stitch it all back together.+  -- If 'x' occurs many times we may get many identical+  -- bindings of the same SplicePointName, but that doesn't+  -- matter, although it's a mite untidy.+tcUntypedSplice q splice_name (XUntypedSplice ils)+  = do { let id_name = implicit_lift_lid ils+       ; id_ty <- newOpenFlexiTyVarTy+       ; let v_expr = noLocA (HsVar noExtField id_name)+       ; v_expr' <- tcCheckMonoExpr v_expr id_ty+       -- lift :: Quote m' => a -> m' Exp+       ; lift <- setSrcSpan (getLocA id_name) $+                  newMethodFromName (ImplicitLiftOrigin ils)+                                     GHC.Builtin.Names.TH.liftName+                                     [getRuntimeRep id_ty, id_ty]+       ; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) v_expr'++       ; return (PendingTcSplice splice_name res) }++tcPendingSpliceTyped :: QuoteWrapper -> SplicePointName -> HsTypedSplice GhcRn -> ExpRhoType -> TcM PendingTcSplice+tcPendingSpliceTyped q@(QuoteWrapper _ m_var) splice_name (HsTypedSpliceExpr _ expr) res_ty+  = do { res_ty <- expTypeToType res_ty+       ; let rep = getRuntimeRep res_ty+       ; meta_exp_ty <- tcCodeTy m_var res_ty+       ; expr' <- tcCheckMonoExpr expr meta_exp_ty+       ; untype_code <- tcLookupId unTypeCodeName+       ; let expr'' = mkHsApp+                         (mkLHsWrap (applyQuoteWrapper q)+                           (nlHsTyApp untype_code [rep, res_ty])) expr'+       ; return (PendingTcSplice splice_name expr'') }+tcPendingSpliceTyped q splice_name (XTypedSplice ils) res_ty+  = do { let id_name = implicit_lift_lid ils+       ; res_ty <- expTypeToType res_ty+       ; let rep = getRuntimeRep res_ty+       ; let v_expr = noLocA (HsVar noExtField id_name)+       ; v_expr' <- tcCheckMonoExpr v_expr res_ty+       -- lift :: Quote m' => a -> m' Exp+       ; lift <- setSrcSpan (getLocA id_name) $+                  newMethodFromName (ImplicitLiftOrigin ils)+                                     GHC.Builtin.Names.TH.liftName+                                     [rep, res_ty]+       ; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) v_expr'+       ; return (PendingTcSplice splice_name res) }++ --------------- -- Takes a m and tau and returns the type m (TExp tau)-tcTExpTy :: TcType -> TcType -> TcM TcType-tcTExpTy m_ty exp_ty+tcCodeTy :: TcType -> TcType -> TcM TcType+tcCodeTy m_ty exp_ty   = do { unless (isTauTy exp_ty) $ addErr $           TcRnTHError $ TypedTHError $ TypedTHWithPolyType exp_ty        ; codeCon <- tcLookupTyCon codeTyConName        ; let rep = getRuntimeRep exp_ty        ; return (mkTyConApp codeCon [m_ty, rep, exp_ty]) } -quotationCtxtDoc :: LHsExpr GhcRn -> SDoc-quotationCtxtDoc br_body-  = hang (text "In the Template Haskell quotation")-         2 (thTyBrackets . ppr $ br_body) -   -- The whole of the rest of the file is the else-branch (ie stage2 only)  @@ -835,20 +937,35 @@ getUntypedSpliceBody (HsUntypedSpliceNested {})   = panic "tcTopUntypedSplice: invalid nested splice" -tcTypedSplice splice_name expr res_ty-  = addErrCtxt (typedSpliceCtxtDoc splice_name expr) $-    setSrcSpan (getLocA expr)    $ do-    { stage <- getStage-    ; case stage of-          Splice {}            -> tcTopSplice expr res_ty-          Brack pop_stage pend -> tcNestedSplice pop_stage pend splice_name expr res_ty-          RunSplice _          ->-            -- See Note [RunSplice ThLevel] in "GHC.Tc.Types".-            pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++-                      "running another splice") (pprTypedSplice (Just splice_name) expr)-          Comp                 -> tcTopSplice expr res_ty-    }+tcTypedSplice HsTypedSpliceTop ctxt@(HsTypedSpliceExpr _ expr) res_ty+  = addErrCtxt (TypedSpliceCtxt Nothing ctxt) $+    setSrcSpan (getLocA expr)    $+      tcTopSplice expr res_ty+tcTypedSplice (HsTypedSpliceNested sp) expr res_ty+  -- The expr is checked in tcPendingSpliceTyped+  = addErrCtxt (TypedSpliceCtxt (Just sp) expr) $+    setSrcSpan loc    $ do+      lvl <- getThLevel+      case lvl of+        Brack _ (TcPending ps_var lie_var q) -> do+          tc_splice <- setConstraintVar lie_var $ tcPendingSpliceTyped q sp expr res_ty+          updTcRef ps_var (tc_splice : )+          -- stubNestedSplice: the returned expression is ignored; it's in the pending splices.+          --+          -- Unfortunately, this means that tooling that works with typechecked+          -- expressions will not be able to identify where the nested splices are.+          -- Instead, we should modify the extension point of HsTypedSplice, in+          -- order to propagate the result of typechecking. +          return stubNestedSplice+        _ -> panic "tcTypedSplice: invalid level"+  where+    loc = case expr of+            HsTypedSpliceExpr _ expr -> getLocA expr+            XTypedSplice (HsImplicitLiftSplice _ _ _ expr) -> getLocA expr+tcTypedSplice _ _ _ = panic "tcTypedSplice: invalid splice"++ {- Note [Collecting modFinalizers in typed splices]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local@@ -867,13 +984,13 @@          res_ty <- expTypeToType res_ty        ; q_type <- tcMetaTy qTyConName        -- Top level splices must still be of type Q (TExp a)-       ; meta_exp_ty <- tcTExpTy q_type res_ty+       ; meta_exp_ty <- tcCodeTy q_type res_ty        ; q_expr <- tcTopSpliceExpr Typed $                    tcCheckMonoExpr expr meta_exp_ty        ; lcl_env <- getLclEnv        ; let delayed_splice               = DelayedSplice lcl_env expr res_ty q_expr-       ; return (HsTypedSplice delayed_splice q_expr)+       ; return (HsTypedSplice delayed_splice (HsTypedSpliceExpr noExtField q_expr))         } @@ -891,7 +1008,8 @@ tcTopSpliceExpr isTypedSplice tc_action   = checkNoErrs $  -- checkNoErrs: must not try to run the thing                    -- if the type checker fails!-    setStage (Splice isTypedSplice) $++    setThLevel (Splice isTypedSplice Comp) $     do {    -- Typecheck the expression          (mb_expr', wanted) <- tryCaptureConstraints tc_action              -- If tc_action fails (perhaps because of insoluble constraints)@@ -906,32 +1024,6 @@             Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' }  -------------------tcNestedSplice :: ThStage -> PendingStuff -> Name-                -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)-    -- See Note [How brackets and nested splices are handled]-    -- A splice inside brackets-tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty-  = do { res_ty <- expTypeToType res_ty-       ; let rep = getRuntimeRep res_ty-       ; meta_exp_ty <- tcTExpTy m_var res_ty-       ; expr' <- setStage pop_stage $-                  setConstraintVar lie_var $-                  tcCheckMonoExpr expr meta_exp_ty-       ; untype_code <- tcLookupId unTypeCodeName-       ; let expr'' = mkHsApp-                        (mkLHsWrap (applyQuoteWrapper q)-                          (nlHsTyApp untype_code [rep, res_ty])) expr'-       ; ps <- readMutVar ps_var-       ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)--       -- The returned expression is ignored; it's in the pending splices-       ; return stubNestedSplice }--tcNestedSplice _ _ splice_name _ _-  = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)--------------------- -- This is called in the zonker -- See Note [Running typed splices in the zonker] runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)@@ -942,7 +1034,7 @@         -- See Note [Collecting modFinalizers in typed splices].        ; modfinalizers_ref <- newTcRef []          -- Run the expression-       ; expr2 <- setStage (RunSplice modfinalizers_ref) $+       ; expr2 <- setThLevel (RunSplice modfinalizers_ref) $                     runMetaE zonked_q_expr        ; mod_finalizers <- readTcRef modfinalizers_ref        ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers@@ -958,7 +1050,7 @@         -- These steps should never fail; this is a *typed* splice        ; (res, wcs) <-             captureConstraints $-              addErrCtxt (spliceResultDoc zonked_q_expr) $ do+              addErrCtxt (TypedSpliceResultCtxt zonked_q_expr) $ do                 { (exp3, _fvs) <- rnLExpr expr2                 ; tcCheckMonoExpr exp3 zonked_ty }        ; ev <- simplifyTop wcs@@ -974,17 +1066,6 @@ ************************************************************************ -} -typedSpliceCtxtDoc :: SplicePointName -> LHsExpr GhcRn -> SDoc-typedSpliceCtxtDoc n splice-  = hang (text "In the Template Haskell splice")-         2 (pprTypedSplice (Just n) splice)--spliceResultDoc :: LHsExpr GhcTc -> SDoc-spliceResultDoc expr-  = sep [ text "In the result of the splice:"-        , nest 2 (text "$$" <> ppr expr)-        , text "To see what the splice expanded to, use -ddump-splices"]- stubNestedSplice :: HsExpr GhcTc -- Used when we need a (LHsExpr GhcTc) that we are never going -- to look at.  We could use "panic" but that's confusing if we ever@@ -1021,7 +1102,7 @@               ; let loc' = noAnnSrcSpan loc               ; let specialised_to_annotation_wrapper_expr                       = L loc' (mkHsWrap wrapper-                                 (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id)))+                                 (mkHsVar (L (noAnnSrcSpan loc) to_annotation_wrapper_id)))               ; return (L loc' (HsApp noExtField                                 specialised_to_annotation_wrapper_expr expr'))                                 })@@ -1053,11 +1134,7 @@                -- annotation are exposed at this point.  This is also why we are                -- doing all this stuff inside the context of runMeta: it has the                -- facilities to deal with user error in a meta-level expression-               seqSerialized serialized `seq` serialized---- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms-seqSerialized :: Serialized -> ()-seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()+               rnf serialized `seq` serialized  #endif @@ -1101,16 +1178,17 @@  runQResult   :: (a -> String)-  -> (Origin -> SrcSpan -> a -> b)+  -> (EnumSet LangExt.Extension -> Origin -> SrcSpan -> a -> b)   -> (ForeignHValue -> TcM a)   -> SrcSpan   -> ForeignHValue {- TH.Q a -}   -> TcM b runQResult show_th f runQ expr_span hval-  = do { th_result <- runQ hval+  = do { exts <- fmap extensionFlags getDynFlags+       ; th_result <- runQ hval        ; th_origin <- getThSpliceOrigin        ; traceTc "Got TH result:" (text (show_th th_result))-       ; return (f th_origin expr_span th_result) }+       ; return (f exts th_origin expr_span th_result) }   -----------------@@ -1209,8 +1287,6 @@          -> TcM hs_syn           -- Of type t runMeta' show_code ppr_hs run_and_convert expr   = do  { traceTc "About to run" (ppr expr)-        ; recordThSpliceUse -- seems to be the best place to do this,-                            -- we catch all kinds of splices and annotations.          -- Check that we've had no errors of any sort so far.         -- For example, if we found an error in an earlier defn f, but@@ -1455,9 +1531,10 @@     liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix    qAddTopDecls thds = do+      exts <- fmap extensionFlags getDynFlags       l <- getSrcSpanM       th_origin <- getThSpliceOrigin-      let either_hval = convertToHsDecls th_origin l thds+      let either_hval = convertToHsDecls exts th_origin l thds       ds <- case either_hval of               Left exn -> failWithTc $ TcRnTHError $ AddTopDeclsError $                 AddTopDeclsRunSpliceFailure exn@@ -1668,15 +1745,15 @@ -- | Adds a mod finalizer reference to the local environment. addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () addModFinalizerRef finRef = do-    th_stage <- getStage-    case th_stage of+    th_lvl <- getThLevel+    case th_lvl of       RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)       -- This case happens only if a splice is executed and the caller does-      -- not set the 'ThStage' to 'RunSplice' to collect finalizers.+      -- not set the 'ThLevel' to 'RunSplice' to collect finalizers.       -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.       _ ->         pprPanic "addModFinalizer was called when no finalizers were collected"-                 (ppr th_stage)+                 (ppr th_lvl)  -- | Releases the external interpreter state. finishTH :: TcM ()@@ -1898,11 +1975,11 @@                 -- ^ Returns 'Left' in the case that the instances were found to                 -- be class instances, or 'Right' if they are family instances. reifyInstances' th_nm th_tys-   = addErrCtxt (text "In the argument of reifyInstances:"-                 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $-     do { loc <- getSrcSpanM+   = addErrCtxt (ReifyInstancesCtxt th_nm th_tys) $+     do { exts <- fmap extensionFlags getDynFlags+        ; loc <- getSrcSpanM         ; th_origin <- getThSpliceOrigin-        ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys)+        ; rdr_ty <- cvt exts th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys)           -- #9262 says to bring vars into scope, like in HsForAllTy case           -- of rnHsTyKi         ; tv_rdrs <- filterInScopeM $ extractHsTyRdrTyVars rdr_ty@@ -1946,11 +2023,11 @@                      ; return $ Right (tc, map fim_instance matches) }             _  -> bale_out $ TcRnTHError $ THReifyError $ CannotReifyInstance ty }   where-    doc = ClassInstanceCtx+    doc = ReifyInstancesCtx     bale_out msg = failWithTc msg -    cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)-    cvt origin loc th_ty = case convertToHsType origin loc th_ty of+    cvt :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)+    cvt exts origin loc th_ty = case convertToHsType exts origin loc th_ty of       Left msg -> failWithTc (TcRnTHError $ THSpliceFailed $ RunSpliceFailure msg)       Right ty -> return ty @@ -2030,7 +2107,8 @@  lookupThName_maybe :: TH.Name -> TcM (Maybe Name) lookupThName_maybe th_name-  =  do { let guesses = thRdrNameGuesses th_name+  =  do { listTuplePuns <- xoptM LangExt.ListTuplePuns+        ; let guesses = thRdrNameGuesses listTuplePuns th_name         ; case guesses of         { [for_sure] -> lookupSameOccRn_maybe for_sure         ; _ ->@@ -2293,13 +2371,21 @@              ret_con | null ex_tvs' && null theta' = return main_con                      | otherwise                   = do                          { cxt <- reifyCxt theta'-                         ; ex_tvs'' <- reifyTyVarBndrs ex_tvs'+                         ; ex_tvs'' <- case to_invis_bndrs ex_tvs' of+                             Nothing  -> noTH DataConVisibleForall (dataConDisplayType False dc)+                             Just tvs -> reifyTyVarBndrs tvs                          ; return (TH.ForallC ex_tvs'' cxt main_con) }        ; assert (r_arg_tys `equalLength` dcdBangs)          ret_con }   where-    mk_specified tv = Bndr tv SpecifiedSpec+    mk_specified tv = Bndr tv Specified +    to_invis_bndrs :: [TyVarBinder] -> Maybe [InvisTVBinder]+    to_invis_bndrs = traverse $ \(Bndr tv vis) ->+      case vis of+        Invisible spec -> Just (Bndr tv spec)+        Required -> Nothing+     subst_tv_binders subst tv_bndrs =       let tvs            = binderVars tv_bndrs           flags          = binderFlags tv_bndrs@@ -2840,7 +2926,7 @@  reifySourceBang :: DataCon.HsSrcBang                 -> (TH.SourceUnpackedness, TH.SourceStrictness)-reifySourceBang (HsSrcBang _ (HsBang u s)) = (reifyUnpackedness u, reifyStrictness s)+reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)  reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness reifyDecidedStrictness HsLazy       = TH.DecidedLazy@@ -2898,26 +2984,19 @@        reifyFromIface reifMod = do         iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod-        let usages = [modToTHMod m | usage <- mi_usages iface,-                                     Just m <- [usageToModule (moduleUnit reifMod) usage] ]+        let IfaceTopEnv _ imports = mi_top_env iface+            -- Convert IfaceImport to module names+            usages = [modToTHMod (ifImpModule imp) | imp <- imports]         return $ TH.ModuleInfo usages -      usageToModule :: Unit -> Usage -> Maybe Module-      usageToModule _ (UsageFile {}) = Nothing-      usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn-      usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m-      usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m-      usageToModule this_pkg (UsageHomeModuleInterface { usg_mod_name = mn }) = Just $ mkModule this_pkg mn + ------------------------------ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys  noTH :: UnrepresentableTypeDescr -> Type -> TcM a noTH s d = failWithTc $ TcRnTHError $ THReifyError $ CannotRepresentType s d--ppr_th :: TH.Ppr a => a -> SDoc-ppr_th x = text (TH.pprint x)  tcGetInterp :: TcM Interp tcGetInterp = do
compiler/GHC/Tc/Gen/Splice.hs-boot view
@@ -10,11 +10,11 @@ import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) -import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult )+import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult, HsTypedSpliceResult, HsTypedSplice ) import qualified GHC.Boot.TH.Syntax as TH -tcTypedSplice :: Name-              -> LHsExpr GhcRn+tcTypedSplice :: HsTypedSpliceResult+              -> HsTypedSplice GhcRn               -> ExpRhoType               -> TcM (HsExpr GhcTc) 
compiler/GHC/Tc/Instance/Class.hs view
@@ -1,19 +1,17 @@ {-# LANGUAGE MultiWayIf #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Tc.Instance.Class (      matchGlobalInst, matchEqualityInst,      ClsInstResult(..),      InstanceWhat(..), safeOverlap, instanceReturnsDictCon,-     AssocInstInfo(..), isNotAssociated+     AssocInstInfo(..), isNotAssociated,+     lookupHasFieldLabel   ) where  import GHC.Prelude  import GHC.Driver.DynFlags -import GHC.Core.TyCo.Rep- import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType@@ -21,8 +19,10 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence-import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping)-import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )+import GHC.Tc.Types.CtLoc+import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) )+import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs )+ import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )  import GHC.Builtin.Types@@ -32,13 +32,15 @@ import GHC.Builtin.PrimOps.Ids ( primOpId )  import GHC.Types.FieldLabel-import GHC.Types.Name.Reader import GHC.Types.SafeHaskell import GHC.Types.Name   ( Name )+import GHC.Types.Name.Reader import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Types.Var +import GHC.Core.TyCo.Rep import GHC.Core.Predicate import GHC.Core.Coercion import GHC.Core.InstEnv@@ -47,8 +49,7 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class--import GHC.Core ( Expr(..) )+import GHC.Core ( Expr(..), mkConApp )  import GHC.StgToCmm.Closure ( isSmallFamily ) @@ -62,11 +63,8 @@ import GHC.Hs.Extension  import Language.Haskell.Syntax.Basic (FieldLabelString(..))-import GHC.Types.Id.Info import GHC.Tc.Errors.Types-import Control.Monad -import Data.Functor import Data.Maybe  {- *******************************************************************@@ -137,11 +135,12 @@ matchGlobalInst :: DynFlags                 -> Bool      -- True <=> caller is the short-cut solver                              -- See Note [Shortcut solving: overlap]-                -> Class -> [Type] -> TcM ClsInstResult+                -> Class -> [Type] -> Maybe CtLoc+                -> TcM ClsInstResult -- Precondition: Class does not satisfy GHC.Core.Predicate.isEqualityClass -- (That is handled by a separate code path: see GHC.Tc.Solver.Dict.solveDict, --  which calls solveEqualityDict for equality classes.)-matchGlobalInst dflags short_cut clas tys+matchGlobalInst dflags short_cut clas tys mb_loc   | cls_name == knownNatClassName      = matchKnownNat    dflags short_cut clas tys   | cls_name == knownSymbolClassName   = matchKnownSymbol dflags short_cut clas tys   | cls_name == knownCharClassName     = matchKnownChar   dflags short_cut clas tys@@ -149,12 +148,16 @@   | cls_name == typeableClassName      = matchTypeable                     clas tys   | cls_name == withDictClassName      = matchWithDict                          tys   | cls_name == dataToTagClassName     = matchDataToTag                    clas tys-  | cls_name == hasFieldClassName      = matchHasField    dflags short_cut clas tys-  | cls_name == unsatisfiableClassName = return NoInstance -- See (B) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors+  | cls_name == hasFieldClassName      = matchHasField    dflags short_cut clas tys mb_loc+  | cls_name == unsatisfiableClassName = matchUnsatisfiable   | otherwise                          = matchInstEnv     dflags short_cut clas tys   where     cls_name = className clas +matchUnsatisfiable :: TcM ClsInstResult+-- See (B) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors+matchUnsatisfiable+  = return NoInstance  {- ******************************************************************** *                                                                     *@@ -223,7 +226,6 @@                                                              , iw_safe_over = so                                                              , iw_warn = warn } } } - {- Note [Shortcut solving: overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have@@ -254,13 +256,10 @@ matchCTuple :: Class -> [Type] -> TcM ClsInstResult matchCTuple clas tys   -- (isCTupleClass clas) holds   = return (OneInst { cir_new_theta   = tys-                    , cir_mk_ev       = tuple_ev+                    , cir_mk_ev       = evDictApp clas tys                     , cir_canonical   = EvCanonical                     , cir_what        = BuiltinInstance })             -- The dfun *is* the data constructor!-  where-     data_con = tyConSingleDataCon (classTyCon clas)-     tuple_ev = evDFunApp (dataConWrapId data_con) tys  {- ******************************************************************** *                                                                     *@@ -407,26 +406,26 @@ --     The process is mirrored for Symbols: --     String    -> SSymbol n --     SSymbol n -> KnownSymbol n-makeLitDict clas ty et-    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]-          -- co_dict :: KnownNat n ~ SNat n-    , [ meth ]   <- classMethods clas-    , Just tcRep <- tyConAppTyCon_maybe (classMethodTy meth)-                    -- If the method type is forall n. KnownNat n => SNat n-                    -- then tcRep is SNat-    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]-          -- SNat n ~ Integer-    , let ev_tm = mkEvCast et (mkSymCo (mkTransCo co_dict co_rep))-    = return $ OneInst { cir_new_theta   = []-                       , cir_mk_ev       = \_ -> ev_tm-                       , cir_canonical   = EvCanonical-                       , cir_what        = BuiltinInstance }+makeLitDict clas lit_ty lit_expr+  | [meth]      <- classMethods clas+  , Just rep_tc <- tyConAppTyCon_maybe (classMethodTy meth)+                  -- If the method type is forall n. KnownNat n => SNat n+                  -- then rep_tc :: TyCon is SNat+  , [rep_con]  <- tyConDataCons rep_tc+  = do { let mk_ev _ = evDictApp clas [lit_ty] $+                       [mkConApp rep_con [Type lit_ty, lit_expr]]+       ; return $ OneInst { cir_new_theta   = []+                          , cir_mk_ev       = mk_ev+                          , cir_canonical   = EvCanonical+                          , cir_what        = BuiltinInstance } } -    | otherwise-    = pprPanic "makeLitDict" $-      text "Unexpected evidence for" <+> ppr (className clas)-      $$ vcat (map (ppr . idType) (classMethods clas))+  | otherwise+  = pprPanic "makeLitDict" $+    text "Unexpected evidence for" <+> ppr (className clas)+    $$ vcat (map (ppr . idType) (classMethods clas)) ++ {- ******************************************************************** *                                                                     *                    Class lookup for WithDict@@ -435,38 +434,33 @@  -- See Note [withDict] matchWithDict :: [Type] -> TcM ClsInstResult-matchWithDict [cls, mty]-    -- Check that cls is a class constraint `C t_1 ... t_n`, where+matchWithDict [cls_ty, mty]+    -- Check that cls_ty is a class constraint `C t_1 ... t_n`, where     -- `dict_tc = C` and `dict_args = t_1 ... t_n`.-  | Just (dict_tc, dict_args) <- tcSplitTyConApp_maybe cls+  | Just (dict_tc, dict_args) <- tcSplitTyConApp_maybe cls_ty     -- Check that C is a class of the form     -- `class C a_1 ... a_n where op :: meth_ty`-    -- and in that case let-    -- co :: C t1 ..tn ~R# inst_meth_ty-  , Just (inst_meth_ty, co) <- tcInstNewTyCon_maybe dict_tc dict_args+  , Just (cls, dict_dc) <- isUnaryClassTyCon_maybe dict_tc+  , [inst_meth_ty] <- dataConInstArgTys dict_dc dict_args   = do { sv <- mkSysLocalM (fsLit "withDict_s") ManyTy mty-       ; k  <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls openAlphaTy)+       ; k  <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls_ty openAlphaTy)+       ; wd_cls <- tcLookupClass withDictClassName -       -- Given co2 : mty ~N# inst_meth_ty, construct the method of+       -- Given ev_expr : mty ~N# inst_meth_ty, construct the method of        -- the WithDict dictionary:        --        --   \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) ->-       --     k (sv |> (sub co ; sym co2))-       ; let evWithDict co2 =-               mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $-                 Var k-                   `App`-                 (Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co))+       --     k (MkC tys (sv |> sub co2))+       ; let evWithDict ev_expr+               = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $+                 Var k `App` (evUnaryDictAppE cls dict_args meth_arg)+               where+                 meth_arg = Var sv `Cast` mkSubCo (evExprCoercion ev_expr) -       ; tc <- tcLookupTyCon withDictClassName-       ; let Just withdict_data_con-                 = tyConSingleDataCon_maybe tc    -- "Data constructor"-                                                  -- for WithDict-             mk_ev [c] = evDataConApp withdict_data_con-                            [cls, mty] [evWithDict (evTermCoercion (EvExpr c))]+       ; let mk_ev [c] = evDictApp wd_cls [cls_ty, mty] [evWithDict c]              mk_ev e   = pprPanic "matchWithDict" (ppr e) -       ; return $ OneInst { cir_new_theta   = [mkPrimEqPred mty inst_meth_ty]+       ; return $ OneInst { cir_new_theta   = [mkNomEqPred mty (scaledThing inst_meth_ty)]                           , cir_mk_ev       = mk_ev                           , cir_canonical   = EvNonCanonical -- See (WD6) in Note [withDict]                           , cir_what        = BuiltinInstance }@@ -519,11 +513,11 @@  instance (mty ~# inst_meth_ty) => WithDict (C t1..tn) mty where   withDict = \@{rr} @(r :: TYPE rr) (sv :: mty) (k :: C t1..tn => r) ->-    k (sv |> (sub co2 ; sym co))+    k (MkC (sv |> sub co)))  That is, it matches on the first (constraint) argument of C; if C is a single-method class, the instance "fires" and emits an equality-constraint `mty ~ inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`.+constraint `mty ~# inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`. The coercion `co2` witnesses the equality `mty ~ inst_meth_ty`.  The coercion `co` is a newtype coercion that coerces from `C t1 ... tn`@@ -616,11 +610,65 @@       overloaded function `f` (e.g. with a type such as `f :: Eq a => ...`).        See test-case T21575b.+-}  +{- ********************************************************************+*                                                                     *+                   Class lookup for DataToTag+*                                                                     *+***********************************************************************-} -Note [DataToTag overview]-~~~~~~~~~~~~~~~~~~~~~~~~~+matchDataToTag :: Class -> [Type] -> TcM ClsInstResult+-- See Note [DataToTag overview]+matchDataToTag dataToTagClass [levity, dty] = do+  famEnvs <- tcGetFamInstEnvs+  (gbl_env, _lcl_env) <- getEnvs+  platform <- getPlatform+  if | isConcreteType levity -- condition C3+     , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty+     , let (repTyCon, repArgs, repCo)+             = tcLookupDataFamInst famEnvs rawTyCon rawTyConArgs++     -- Condition C1+     , Just constrs <- tyConDataCons_maybe repTyCon+     , not (isTypeDataTyCon repTyCon || isNewTyCon repTyCon)++     -- Condition C2+     , let  rdr_env = tcg_rdr_env gbl_env+            inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con+     , all inScope constrs++     , let  repTy = mkTyConApp repTyCon repArgs+            numConstrs = tyConFamilySize repTyCon+            !whichOp -- see wrinkle DTW4+              | isSmallFamily platform numConstrs+                = primOpId DataToTagSmallOp+              | otherwise+                = primOpId DataToTagLargeOp++            -- See wrinkle DTW1; we must apply the underlying+            -- operation at the representation type and cast it+            methodRep = Var whichOp `App` Type levity `App` Type repTy+            methodCo = mkFunCo Representational+                               FTF_T_T+                               (mkNomReflCo ManyTy)+                               (mkSymCo repCo)+                               (mkReflCo Representational intPrimTy)+     -> do { addUsedDataCons rdr_env repTyCon   -- See wrinkles DTW2 and DTW3+           ; let mk_ev _ = evDictApp dataToTagClass [levity, dty] $+                           [methodRep `Cast` methodCo]+           ; pure (OneInst { cir_new_theta = [] -- (Ignore stupid theta.)+                           , cir_mk_ev     = mk_ev+                           , cir_canonical = EvCanonical+                           , cir_what = BuiltinInstance })}+     | otherwise -> pure NoInstance++matchDataToTag _ _ = pure NoInstance+++{- Note [DataToTag overview]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Class `DataToTag` is defined like this, in GHC.Magic:    type DataToTag :: forall {lev :: Levity}.@@ -647,10 +695,11 @@        * a "data" declaration,        * a "data instance" declaration,        * a boxed tuple type-      "type data" declarations are NOT included; see also wrinkle W2c-      of Note [Type data declarations] in GHC.Rename.Module.-      (In principle we could accept newtypes that wrap algebraic data-      types, but we do not do so.)+      But NOT+       * A "type data" declaration; see also wrinkle W2c+         of Note [Type data declarations] in GHC.Rename.Module.+       * A newtype; in principle we could accept newtypes that wrap+         an algebraic data type, but we do not do so.  C2: All of the constructors of that "data" or "data instance"       declaration are in scope.  Otherwise, `dataToTag#` could be@@ -725,7 +774,7 @@ H3. Each evaluates its argument.  But we want to omit this eval when the     actual argument is already evaluated and properly tagged.  To do this, -    * We have a special case in GHC.Stg.InferTags.Rewrite.rewriteOpApp+    * We have a special case in GHC.Stg.EnforceEpt.Rewrite.rewriteOpApp       ensuring that any inferred tag information on the argument is       retained until code generation. @@ -885,71 +934,12 @@ Today, that story is simple: A dataToTag primop always evaluates its argument, unless tag inference determines the argument was already evaluated and correctly tagged.  Getting here was a long journey, with-many similarities to the story behind Note [Strict Field Invariant] in-GHC.Stg.InferTags.  See also #15696.-+many similarities to the story behind Note [Evaluated and Properly Tagged] in+GHC.Stg.EnforceEpt.  See also #15696. -} - {- ******************************************************************** *                                                                     *-                   Class lookup for DataToTag-*                                                                     *-***********************************************************************-}--matchDataToTag :: Class -> [Type] -> TcM ClsInstResult--- See Note [DataToTag overview]-matchDataToTag dataToTagClass [levity, dty] = do-  famEnvs <- tcGetFamInstEnvs-  (gbl_env, _lcl_env) <- getEnvs-  platform <- getPlatform-  if | isConcreteType levity -- condition C3-     , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty-     , let (repTyCon, repArgs, repCo)-             = tcLookupDataFamInst famEnvs rawTyCon rawTyConArgs--     , not (isTypeDataTyCon repTyCon)-     , Just constrs <- tyConAlgDataCons_maybe repTyCon-         -- condition C1--     , let  rdr_env = tcg_rdr_env gbl_env-            inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con-     , all inScope constrs -- condition C2--     , let  repTy = mkTyConApp repTyCon repArgs-            numConstrs = tyConFamilySize repTyCon-            !whichOp -- see wrinkle DTW4-              | isSmallFamily platform numConstrs-                = primOpId DataToTagSmallOp-              | otherwise-                = primOpId DataToTagLargeOp--            -- See wrinkle DTW1; we must apply the underlying-            -- operation at the representation type and cast it-            methodRep = Var whichOp `App` Type levity `App` Type repTy-            methodCo = mkFunCo Representational-                               FTF_T_T-                               (mkNomReflCo ManyTy)-                               (mkSymCo repCo)-                               (mkReflCo Representational intPrimTy)-            dataToTagDataCon = tyConSingleDataCon (classTyCon dataToTagClass)-            mk_ev _ = evDataConApp dataToTagDataCon-                                   [levity, dty]-                                   [methodRep `Cast` methodCo]-     -> addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3-          $> OneInst { cir_new_theta = [] -- (Ignore stupid theta.)-                     , cir_mk_ev = mk_ev-                     , cir_canonical = EvCanonical-                     , cir_what = BuiltinInstance-                     }-     | otherwise -> pure NoInstance--matchDataToTag _ _ = pure NoInstance----{- ********************************************************************-*                                                                     *                    Class lookup for Typeable *                                                                     * ***********************************************************************-}@@ -994,8 +984,8 @@                      , cir_what        = BuiltinInstance }   where     preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty]-    mk_ev [mult_ev, arg_ev, ret_ev] = evTypeable ty $-                        EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev)+    mk_ev [mult_ev, arg_ev, ret_ev]+       = evTypeable ty $ EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev)     mk_ev _ = panic "GHC.Tc.Instance.Class.doFunTy"  @@ -1147,21 +1137,21 @@ ***********************************************************************-}  -- See also Note [The equality types story] in GHC.Builtin.Types.Prim-matchEqualityInst :: Class -> [Type] -> (DataCon, Role, Type, Type)+matchEqualityInst :: Class -> [Type] -> (Role, Type, Type) -- Precondition: `cls` satisfies GHC.Core.Predicate.isEqualityClass -- See Note [Solving equality classes] in GHC.Tc.Solver.Dict matchEqualityInst cls args   | cls `hasKey` eqTyConKey  -- Solves (t1 ~ t2)   , [_,t1,t2] <- args-  = (eqDataCon, Nominal, t1, t2)+  = (Nominal, t1, t2)    | cls `hasKey` heqTyConKey -- Solves (t1 ~~ t2)   , [_,_,t1,t2] <- args-  = (heqDataCon,  Nominal, t1, t2)+  = (Nominal, t1, t2)    | cls `hasKey` coercibleTyConKey  -- Solves (Coercible t1 t2)   , [_, t1, t2] <- args-  = (coercibleDataCon, Representational, t1, t2)+  = (Representational, t1, t2)    | otherwise  -- Does not satisfy the precondition   = pprPanic "matchEqualityInst" (ppr (mkClassPred cls args))@@ -1173,61 +1163,42 @@ *                                                                     * ***********************************************************************-} -{--Note [HasField instances]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--    data T y = MkT { foo :: [y] }--and `foo` is in scope.  Then GHC will automatically solve a constraint like--    HasField "foo" (T Int) b--by emitting a new wanted--    T alpha -> [alpha] ~# T Int -> b--and building a HasField dictionary out of the selector function `foo`,-appropriately cast.--The HasField class is defined (in GHC.Records) thus:+{- Note [HasField instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Recall that the HasField class is defined (in GHC.Records) thus: -    type HasField :: forall {k} {r_rep} {a_rep} . k -> TYPE r_rep -> TYPE a_rep -> Constraint+    type HasField :: forall {k} {r_rep} {a_rep} .+                     k -> TYPE r_rep -> TYPE a_rep -> Constraint     class HasField x r a | x r -> a where       getField :: r -> a -Since this is a one-method class, it is represented as a newtype.-Hence we can solve `HasField "foo" (T Int) b` by taking an expression-of type `T Int -> b` and casting it using the newtype coercion.-Note that--    foo :: forall y . T y -> [y]--so the expression we construct is--    foo @alpha |> co--where+Suppose we have+    data T y = MkT { foo :: [y] }+and `foo` is in scope, with type+    foo :: forall y. T y -> [y] -    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b+Then `matchHasField` implements the followind built-in magic to solve+         [W] d : HasField "foo" (T rty) fty -is built from+  * Check that `T` has a field `foo`, and get the selector Id, sel_id+    This is done by `lookupHasFieldLabel` -    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)+  * Instantiate sel_id's type, giving:  T alpha -> [alpha] -which is the new wanted, and+  * Generating a new Wanted+      [W] co : (T alpha -> [alpha]) ~# (T rty -> fty) -    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b+  * Solve the original Wanted via+      d = MkHasField (sel_id @alpha |> co) -which can be derived from the newtype coercion.+Wrinkles: -If `foo` is not in scope, or has a higher-rank or existentially-quantified type, then the constraint is not solved automatically, but-may be solved by a user-supplied HasField instance.  Similarly, if we-encounter a HasField constraint where the field is not a literal-string, or does not belong to the type, then we fall back on the-normal constraint solver behaviour.+(HF1) If `foo` is not in scope, or is "naughty" (has a higher-rank or+  existentially quantified type), then the constraint is not solved+  automatically, but may be solved by a user-supplied HasField instance.+  Similarly, if we encounter a HasField constraint where the field is not a+  literal string, or does not belong to the type, then we fall back on the+  normal constraint solver behaviour.   Note [Unused name reporting and HasField]@@ -1245,26 +1216,15 @@ -}  -- See Note [HasField instances]-matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult-matchHasField dflags short_cut clas tys+matchHasField :: DynFlags -> Bool -> Class -> [Type]+              -> Maybe CtLoc        -- Nothing used only during type validity checking+              -> TcM ClsInstResult+matchHasField dflags short_cut clas tys mb_ct_loc   = do { fam_inst_envs <- tcGetFamInstEnvs        ; rdr_env       <- getGlobalRdrEnv-       ; case tys of-           -- We are matching HasField {k} {r_rep} {a_rep} x r a...-           [_k_ty, _r_rep, _a_rep, x_ty, r_ty, a_ty]-               -- x should be a literal string-             | Just x <- isStrLitTy x_ty-               -- r should be an applied type constructor-             , Just (tc, args) <- tcSplitTyConApp_maybe r_ty-               -- use representation tycon (if data family); it has the fields-             , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)-               -- x should be a field of r-             , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc-               -- the field selector should be in scope-             , Just gre <- lookupGRE_FieldLabel rdr_env fl--             -> do { let name = flSelector fl-                   ; sel_id <- tcLookupId name+       ; case lookupHasFieldLabel fam_inst_envs rdr_env tys of+            Just (sel_name, gre, r_ty, a_ty) ->+                do { sel_id <- tcLookupId sel_name                    ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id                           -- The first new wanted constraint equates the actual@@ -1272,37 +1232,93 @@                          -- the HasField x r a dictionary.  The preds will                          -- typically be empty, but if the datatype has a                          -- "stupid theta" then we have to include it here.-                   ; let theta = mkPrimEqPred sel_ty (mkVisFunTyMany r_ty a_ty) : preds+                   ; let tvs   = mkTyVarTys (map snd tv_prs)+                         theta = mkNomEqPred sel_ty (mkVisFunTyMany r_ty a_ty) : preds                           -- Use the equality proof to cast the selector Id to-                         -- type (r -> a), then use the newtype coercion to cast-                         -- it to a HasField dictionary.-                         mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co-                           where-                             co = mkSubCo (evTermCoercion (EvExpr ev1))-                                      `mkTransCo` mkSymCo co2+                         -- type (r -> a), then use evUnaryDictAppE to turn it+                         -- into a HasField dictionary.+                         mk_ev (ev1:evs) = EvExpr                   $+                                           evUnaryDictAppE clas tys $+                                           evCastE (evSelector sel_id tvs evs)+                                                   (mkSubCo (evExprCoercion ev1))                          mk_ev [] = panic "matchHasField.mk_ev" -                         Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)-                                                              tys+                     -- The selector must not be "naughty" (i.e. the field+                     -- cannot have an existentially quantified type),+                     -- and it must not be higher-rank.+                   ; if (isNaughtyRecordSelector sel_id) || not (isTauTy sel_ty)+                     then try_user_instances+                     else+                do { case mb_ct_loc of+                       Nothing -> return ()  -- Nothing: happens when type-validity checking+                       Just loc ->  setCtLocM loc $  -- Set location for warnings+                         do { -- See Note [Unused name reporting and HasField]+                              addUsedGRE AllDeprecationWarnings gre+                            ; keepAlive sel_name -                         tvs = mkTyVarTys (map snd tv_prs)+                              -- Warn about incomplete record selection+                           ; warnIncompleteRecSel dflags sel_id loc } -                     -- The selector must not be "naughty" (i.e. the field-                     -- cannot have an existentially quantified type), and-                     -- it must not be higher-rank.-                   ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty-                     then do { -- See Note [Unused name reporting and HasField]-                               addUsedGRE AllDeprecationWarnings gre-                             ; keepAlive name-                             ; unless (null $ snd $ sel_cons $ idDetails sel_id)-                                 $ addDiagnostic $ TcRnHasFieldResolvedIncomplete name-                                 -- Only emit an incomplete selector warning if it's an implicit instance-                                 -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc-                             ; return OneInst { cir_new_theta   = theta-                                              , cir_mk_ev       = mk_ev-                                              , cir_canonical   = EvCanonical-                                              , cir_what        = BuiltinInstance } }-                     else matchInstEnv dflags short_cut clas tys }+                   ; return OneInst { cir_new_theta   = theta+                                    , cir_mk_ev       = mk_ev+                                    , cir_canonical   = EvCanonical+                                    , cir_what        = BuiltinInstance } } } -           _ -> matchInstEnv dflags short_cut clas tys }+            Nothing -> try_user_instances }+   where+     -- See (HF1) in Note [HasField instances]+     try_user_instances = matchInstEnv dflags short_cut clas tys++warnIncompleteRecSel :: DynFlags -> Id -> CtLoc -> TcM ()+-- Warn about incomplete record selectors+-- See (IRS6) in Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc+warnIncompleteRecSel dflags sel_id ct_loc+  | not (isGetFieldOrigin (ctLocOrigin ct_loc))+      -- isGetFieldOrigin: see (IRS7) in+      -- Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc+  , RecSelId { sel_cons = RSI { rsi_undef = fallible_cons } } <- idDetails sel_id+  , not (null fallible_cons)+  = addDiagnostic $+    TcRnHasFieldResolvedIncomplete (idName sel_id) fallible_cons maxCons++  | otherwise+  = return ()+  where+    maxCons = maxUncoveredPatterns dflags++    -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin,+    -- despite the expansion to (getField @"x" r)+    isGetFieldOrigin (GetFieldOrigin {}) = True+    isGetFieldOrigin _                   = False++lookupHasFieldLabel+  :: FamInstEnvs -> GlobalRdrEnv -> [Type]+  -> Maybe ( Name          -- Name of the record selector+           , GlobalRdrElt  -- GRE for the selector+           , Type          -- Type of the record value+           , Type )        -- Type of the field of the record+-- If possible, decompose application+--     (HasField @k @rrep @arep @"fld" @(T t1..tn) @fld-ty),+--  or (getField @k @rrep @arep @"fld" @(T t1..tn) @fld-ty)+-- and return the pieces, if the record selector is in scope+--+-- A complication is that `T` might be a data family, so we need to+-- look it up in the `fam_envs` to find its representation tycon.+lookupHasFieldLabel fam_inst_envs rdr_env arg_tys+  |  -- We are matching HasField {k} {r_rep} {a_rep} x r a...+    (_k : _rec_rep : _fld_rep : x_ty : rec_ty : fld_ty : _) <- arg_tys+    -- x should be a literal string+  , Just x <- isStrLitTy x_ty+    -- r should be an applied type constructor+  , Just (tc, args) <- tcSplitTyConApp_maybe rec_ty+    -- Use the representation tycon (if data family); it has the fields+  , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)+    -- x should be a field of r+  , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc+    -- Ensure the field selector is in scope+  , Just gre <- lookupGRE_FieldLabel rdr_env fl+  = Just (flSelector fl, gre, rec_ty, fld_ty)++  | otherwise+  = Nothing
compiler/GHC/Tc/Instance/Family.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE GADTs, ViewPatterns #-}+{-# LANGUAGE GADTs, ViewPatterns, LambdaCase #-}  -- | The @FamInst@ type: family instance heads module GHC.Tc.Instance.Family (         FamInstEnvs, tcGetFamInstEnvs,         checkFamInstConsistency, tcExtendLocalFamInstEnv,         tcLookupDataFamInst, tcLookupDataFamInst_maybe,-        tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,+        tcTopNormaliseNewTypeTF_maybe,          -- * Injectivity         reportInjectivityErrors, reportConflictingInjectivityErrs@@ -34,9 +34,7 @@ import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Deps-import GHC.Unit.Home.ModInfo  import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name.Reader@@ -57,8 +55,8 @@ import Data.Function ( on )  import qualified GHC.LanguageExtensions  as LangExt-import GHC.Unit.Env (unitEnv_hpts) import Data.List (sortOn)+import qualified GHC.Unit.Home.Graph as HUG  {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -294,47 +292,44 @@        ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)        ; let { -- Fetch the iface of a given module.  Must succeed as                -- all directly imported modules must already have been loaded.-               modIface mod =-                 case lookupIfaceByModule hug (eps_PIT eps) mod of+               modIface mod = liftIO $+                 lookupIfaceByModule hug (eps_PIT eps) mod >>= \case                    Nothing    -> panicDoc "FamInst.checkFamInstConsistency"-                                          (ppr mod $$ ppr hug)-                   Just iface -> iface+                                          (ppr mod $$ ppr (HUG.allUnits hug))+                   Just iface -> pure iface                 -- Which family instance modules were checked for consistency                -- when we compiled `mod`?                -- Itself (if a family instance module) and its dep_finsts.                -- This is df(D_i) from                -- Note [Checking family instance optimization]-             ; modConsistent :: Module -> [Module]-             ; modConsistent mod =-                 if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps-                 where-                 deps = dep_finsts . mi_deps . modIface $ mod+             ; modConsistent :: Module -> TcM [Module]+             ; modConsistent mod = do+                 ifc <- modIface mod+                 deps <- dep_finsts . mi_deps <$> modIface mod+                 pure $+                   if mi_finsts ifc+                      then mod:deps+                      else deps -             ; debug_consistent_set = map (\x -> (x, length (modConsistent x))) directlyImpMods               -- Sorting the list by size has the effect of performing a topological sort.              -- See Note [Order of type family consistency checks]-             ; init_consistent_set = reverse (sortOn (length . modConsistent) directlyImpMods)--             ; hmiModule     = mi_module . hm_iface-             ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv-                               . md_fam_insts . hm_details-             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)-                                           | hpt <- unitEnv_hpts hug-                                           , hmi <- eltsHpt hpt ]-              } +       ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug+       ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods        ; traceTc "init_consistent_set" (ppr debug_consistent_set)+       ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set))        ; checkMany hpt_fam_insts modConsistent init_consistent_set+        }   where     -- See Note [Checking family instance optimization]     checkMany-      :: ModuleEnv FamInstEnv   -- home package family instances-      -> (Module -> [Module])   -- given A, modules checked when A was checked-      -> [Module]               -- modules to process+      :: ModuleEnv FamInstEnv     -- home package family instances+      -> (Module -> TcM [Module]) -- given A, modules checked when A was checked+      -> [Module]                 -- modules to process       -> TcM ()     checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods       where@@ -345,6 +340,36 @@          -> TcM ()       go _ _ [] = return ()       go consistent consistent_set (mod:mods) = do+        mod_deps_consistent <- modConsistent mod+        let+          mod_deps_consistent_set = mkModuleSet mod_deps_consistent+          consistent' = to_check_from_mod ++ consistent+          consistent_set' =+            extendModuleSetList consistent_set to_check_from_mod+          to_check_from_consistent =+            filterOut (`elemModuleSet` mod_deps_consistent_set) consistent+          to_check_from_mod =+            filterOut (`elemModuleSet` consistent_set) mod_deps_consistent+            -- Why don't we just minusModuleSet here (above)?+            -- We could, but doing so means one of two things:+            --+            --   1. When looping over the cartesian product we convert+            --   a set into a non-deterministically ordered list. Which+            --   happens to be fine for interface file determinism+            --   in this case, today, because the order only+            --   determines the order of deferred checks. But such+            --   invariants are hard to keep.+            --+            --   2. When looping over the cartesian product we convert+            --   a set into a deterministically ordered list - this+            --   adds some additional cost of sorting for every+            --   direct import.+            --+            --   That also explains why we need to keep both 'consistent'+            --   and 'consistentSet'.+            --+            --   See also Note [ModuleEnv performance and determinism].+         traceTc "checkManySize" (vcat [text "mod:" <+> ppr mod                                       , text "m1:" <+> ppr (length to_check_from_mod)                                       , text "m2:" <+> ppr (length (to_check_from_consistent))@@ -358,35 +383,6 @@           , m2 <- to_check_from_consistent           ]         go consistent' consistent_set' mods-        where-        mod_deps_consistent =  modConsistent mod-        mod_deps_consistent_set = mkModuleSet mod_deps_consistent-        consistent' = to_check_from_mod ++ consistent-        consistent_set' =-          extendModuleSetList consistent_set to_check_from_mod-        to_check_from_consistent =-          filterOut (`elemModuleSet` mod_deps_consistent_set) consistent-        to_check_from_mod =-          filterOut (`elemModuleSet` consistent_set) mod_deps_consistent-        -- Why don't we just minusModuleSet here?-        -- We could, but doing so means one of two things:-        ---        --   1. When looping over the cartesian product we convert-        --   a set into a non-deterministically ordered list. Which-        --   happens to be fine for interface file determinism-        --   in this case, today, because the order only-        --   determines the order of deferred checks. But such-        --   invariants are hard to keep.-        ---        --   2. When looping over the cartesian product we convert-        --   a set into a deterministically ordered list - this-        --   adds some additional cost of sorting for every-        --   direct import.-        ---        --   That also explains why we need to keep both 'consistent'-        --   and 'consistentSet'.-        ---        --   See also Note [ModuleEnv performance and determinism].     check hpt_fam_insts m1 m2       = do { env1' <- getFamInsts hpt_fam_insts m1            ; env2' <- getFamInsts hpt_fam_insts m2@@ -410,7 +406,7 @@   | Just env <- lookupModuleEnv hpt_fam_insts mod = return env   | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)                    ; eps <- getEps-                   ; return (expectJust "checkFamInstConsistency" $+                   ; return (expectJust $                              lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }   where     doc = ppr mod <+> text "is a family-instance module"@@ -423,15 +419,6 @@ ************************************************************************  -}---- | If @co :: T ts ~ rep_ty@ then:------ > instNewTyCon_maybe T ts = Just (rep_ty, co)------ Checks for a newtype, and for being saturated--- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion-tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)-tcInstNewTyCon_maybe = instNewTyCon_maybe  -- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if -- there is no data family to unwrap.
compiler/GHC/Tc/Instance/FunDeps.hs view
@@ -578,11 +578,22 @@        = case classifyPredType pred of             EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])]                -- See Note [Equality superclasses]-            ClassPred cls tys  -> [ instFD fd cls_tvs tys-                                  | let (cls_tvs, cls_fds) = classTvsFds cls-                                  , fd <- cls_fds ]++            ClassPred cls tys | not (isIPClass cls)+               -- isIPClass: see Note [closeWrtFunDeps ignores implicit parameters]+                              -> [ instFD fd cls_tvs tys+                                 | let (cls_tvs, cls_fds) = classTvsFds cls+                                 , fd <- cls_fds ]             _ -> [] +{- Note [closeWrtFunDeps ignores implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Implicit params don't really determine a type variable (that is, we might have+IP "c" Bool and IP "c" Int in different places within the same program), and+skipping this causes implicit params to monomorphise too many variables; see+Note [Inheriting implicit parameters] in GHC.Tc.Solver.  Skipping causes+typecheck/should_compile/tc219 to fail.+-}  {- ********************************************************************* *                                                                      *@@ -652,19 +663,19 @@       | instanceCantMatch trimmed_tcs rough_tcs2       = False       | otherwise-      = case tcUnifyTyKis bind_fn ltys1 ltys2 of+      = case tcUnifyFunDeps qtvs ltys1 ltys2 of           Nothing         -> False           Just subst             -> isNothing $   -- Bogus legacy test (#10675)                              -- See Note [Bogus consistency check]-               tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2)+               tcUnifyFunDeps qtvs (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2)        where         trimmed_tcs    = trimRoughMatchTcs cls_tvs fd rough_tcs1         (ltys1, rtys1) = instFD fd cls_tvs tys1         (ltys2, rtys2) = instFD fd cls_tvs tys2         qtv_set2       = mkVarSet qtvs2-        bind_fn        = matchBindFun (qtv_set1 `unionVarSet` qtv_set2)+        qtvs           = qtv_set1 `unionVarSet` qtv_set2      eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2         -- A single instance may appear twice in the un-nubbed conflict list
compiler/GHC/Tc/Instance/Typeable.hs view
@@ -221,18 +221,21 @@       , tycon_rep_id :: !Id       } --- | A group of 'TyCon's in need of type-rep bindings. data TypeRepTodo-    = TypeRepTodo-      { mod_rep_expr    :: LHsExpr GhcTc    -- ^ Module's typerep binding-      , pkg_fingerprint :: !Fingerprint     -- ^ Package name fingerprint-      , mod_fingerprint :: !Fingerprint     -- ^ Module name fingerprint-      , todo_tycons     :: [TypeableTyCon]-        -- ^ The 'TyCon's in need of bindings kinds-      }-    | ExportedKindRepsTodo [(Kind, Id)]+  = TyConTodo TyConTodo+  | ExportedKindRepsTodo [(Kind, Id)]       -- ^ Build exported 'KindRep' bindings for the given set of kinds. ++-- | A group of 'TyCon's in need of type-rep bindings.+data TyConTodo+    = TCTD { mod_rep_expr    :: LHsExpr GhcTc    -- ^ Module's typerep binding+           , pkg_fingerprint :: !Fingerprint     -- ^ Package name fingerprint+           , mod_fingerprint :: !Fingerprint     -- ^ Module name fingerprint+           , todo_tycons     :: [TypeableTyCon]+                -- ^ The 'TyCon's in need of bindings kinds+           }+ todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo todoForTyCons mod mod_id tycons = do     trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName@@ -255,11 +258,11 @@             , Just rep_name <- pure $ tyConRepName_maybe tc''             , tyConIsTypeable tc''             ]-    return TypeRepTodo { mod_rep_expr    = nlHsVar mod_id-                       , pkg_fingerprint = pkg_fpr-                       , mod_fingerprint = mod_fpr-                       , todo_tycons     = typeable_tycons-                       }+    return $ TyConTodo $+             TCTD { mod_rep_expr    = nlHsVar mod_id+                  , pkg_fingerprint = pkg_fpr+                  , mod_fingerprint = mod_fpr+                  , todo_tycons     = typeable_tycons }   where     mod_fpr = fingerprintString $ moduleNameString $ moduleName mod     pkg_fpr = fingerprintString $ unitString $ moduleUnit mod@@ -283,8 +286,8 @@          -- TyCon associated with the applied type constructor).        ; let produced_bndrs :: [Id]              produced_bndrs = [ tycon_rep_id-                              | todo@(TypeRepTodo{}) <- todos-                              , TypeableTyCon {..} <- todo_tycons todo+                              | TyConTodo (TCTD { todo_tycons = tcs }) <- todos+                              , TypeableTyCon {..} <- tcs                               ] ++                               [ rep_id                               | ExportedKindRepsTodo kinds <- todos@@ -293,8 +296,8 @@        ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv         ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]-             mk_binds todo@(TypeRepTodo {}) =-                 mapM (mkTyConRepBinds stuff todo) (todo_tycons todo)+             mk_binds (TyConTodo (todo@(TCTD { todo_tycons = tcs }))) =+                 mapM (mkTyConRepBinds stuff todo) tcs              mk_binds (ExportedKindRepsTodo kinds) =                  mkExportedKindReps stuff kinds >> return [] @@ -413,7 +416,7 @@     return trNameLit  -- | Make Typeable bindings for the given 'TyCon'.-mkTyConRepBinds :: TypeableStuff -> TypeRepTodo+mkTyConRepBinds :: TypeableStuff -> TyConTodo                 -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) mkTyConRepBinds stuff todo (TypeableTyCon {..})   = do -- Make a KindRep@@ -649,7 +652,7 @@       = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)  -- | Produce the right-hand-side of a @TyCon@ representation.-mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo+mkTyConRepTyConRHS :: TypeableStuff -> TyConTodo                    -> TyCon      -- ^ the 'TyCon' we are producing a binding for                    -> LHsExpr GhcTc -- ^ its 'KindRep'                    -> LHsExpr GhcTc
compiler/GHC/Tc/Module.hs view
@@ -16,7 +16,8 @@ -- -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker module GHC.Tc.Module (-        tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,+        tcRnStmt, tcRnExpr, TcRnExprMode(..),+        tcRnType, tcRnTypeSkolemising,         tcRnImportDecls,         tcRnLookupRdrName,         getModuleInterface,@@ -50,6 +51,7 @@ import GHC.Driver.Plugins import GHC.Driver.DynFlags import GHC.Driver.Config.Diagnostic+import GHC.IO.Unsafe ( unsafeInterleaveIO )  import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR (..) ) import GHC.Tc.Errors.Types@@ -60,7 +62,6 @@ import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) import GHC.Tc.Zonk.Type import GHC.Tc.Gen.Expr-import GHC.Tc.Gen.App( tcInferSigma ) import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Export import GHC.Tc.Types.Evidence@@ -71,7 +72,7 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Gen.Default import GHC.Tc.Utils.Env-import GHC.Tc.Gen.Rule+import GHC.Tc.Gen.Sig( tcRules ) import GHC.Tc.Gen.Foreign import GHC.Tc.TyCl.Instance import GHC.Tc.Utils.TcMType@@ -91,7 +92,7 @@ import GHC.Rename.Env import GHC.Rename.Module import GHC.Rename.Doc-import GHC.Rename.Utils ( mkNameClashErr )+import GHC.Rename.Utils ( mkNameClashErr, mkRnSyntaxExpr )  import GHC.Iface.Decl    ( coAxiomToIfaceDecl ) import GHC.Iface.Env     ( externaliseName )@@ -115,6 +116,7 @@ import GHC.Core.Coercion.Axiom import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.TyCo.Ppr( debugPprType )+import GHC.Core.TyCo.Tidy( tidyTopType ) import GHC.Core.FamInstEnv    ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst    , famInstEnvElts, extendFamInstEnvList, normaliseType )@@ -148,9 +150,9 @@ import GHC.Types.Annotations import GHC.Types.SrcLoc import GHC.Types.SourceFile-import GHC.Types.PkgQual import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.Env as UnitEnv import GHC.Unit.External import GHC.Unit.Types import GHC.Unit.State@@ -161,6 +163,7 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Deps+import GHC.Driver.Downsweep  import GHC.Data.FastString import GHC.Data.Maybe@@ -183,6 +186,7 @@ import qualified Data.Map as M import Data.Foldable ( for_ ) import Data.Traversable ( for )+import Data.IORef( newIORef )   @@ -315,6 +319,9 @@                  traceRn "rn1a" empty                ; tcg_env <-                    case hsc_src of+                    -- See Note [Don't typecheck GHC.Internal.Prim]+                    _ | tcg_mod tcg_env1 == gHC_PRIM -> pure tcg_env1+                     HsBootOrSig boot_or_sig ->                       do { tcg_env <- tcRnHsBootDecls boot_or_sig local_decls                          ; traceRn "rn4a: before exports" empty@@ -367,7 +374,16 @@         }       } +{- Note [Don't typecheck GHC.Internal.Prim]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC (currently) can't type-check GHC.Internal.Prim, as that module+contains primitive functions that can't be defined in source Haskell.+The GHC.Internal.Prim source file is only used to generate Haddock documentation;+the actual contents of the module are wired in to GHC.+-}+ {- Note [Disambiguation of multiple default declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  See Note [Named default declarations] in GHC.Tc.Gen.Default @@ -447,7 +463,7 @@  tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM ([NonEmpty ClassDefaults], TcGblEnv) tcRnImports hsc_env import_decls-  = do  { (rn_imports, imp_user_spec, rdr_env, imports, hpc_info) <- rnImports import_decls+  = do  { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls         -- Get the default declarations for the classes imported by this module         -- and group them by class.         ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList))@@ -456,18 +472,21 @@         ; gbl_env <- getGblEnv         ; let unitId = homeUnitId $ hsc_home_unit hsc_env               mnwib = GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env))-        ; let { -- We want instance declarations from all home-package+        ;       -- We want instance declarations from all home-package                 -- modules below this one, including boot modules, except                 -- ourselves.  The 'except ourselves' is so that we don't                 -- get the instances from this module's hs-boot file.  This                 -- filtering also ensures that we don't see instances from                 -- modules batch (@--make@) compiled before this one, but                 -- which are not below this one.-              ; (home_insts, home_fam_insts) =--                    hptInstancesBelow hsc_env unitId mnwib+              ; (home_insts, home_fam_insts) <- liftIO $+                    hugInstancesBelow hsc_env unitId mnwib -              } ;+                -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations+                -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad+                -- and see https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14274#note_620545+              ; completeSigsBelow <- liftIO $ unsafeInterleaveIO $+                    hugCompleteSigsBelow hsc_env unitId mnwib                  -- Record boot-file info in the EPS, so that it's                 -- visible to loadHiBootInterface in tcRnSrcDecls,@@ -481,13 +500,14 @@             gbl {               tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,+              tcg_complete_match_env = tcg_complete_match_env gbl +++                                       completeSigsBelow,               tcg_import_decls = imp_user_spec,               tcg_rn_imports   = rn_imports,               tcg_default      = foldMap subsume tc_defaults,               tcg_inst_env     = tcg_inst_env gbl `unionInstEnv` home_insts,               tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)-                                                      home_fam_insts,-              tcg_hpc          = hpc_info+                                                      home_fam_insts             }) $ do {          ; traceRn "rn1" (ppr (imp_direct_dep_mods imports))@@ -978,6 +998,11 @@   = do  { traceTc "checkHiBootIface" $ vcat              [ ppr boot_type_env, ppr boot_exports ] +        ; mod <- tcg_mod <$> getGblEnv++        -- See Note [Don't typecheck GHC.Internal.Prim]+        ; if mod == gHC_PRIM then pure [] else do {+         ; gre_env <- getGlobalRdrEnv                  -- Check the exports of the boot module, one by one@@ -997,7 +1022,7 @@          ; failIfErrsM -        ; return (fld_prs ++ dfun_prs) }+        ; return (fld_prs ++ dfun_prs) }}    where     boot_dfun_names = map idName boot_dfuns@@ -1795,9 +1820,8 @@           --           -- But only after we've typechecked 'default' declarations.           -- See Note [Typechecking default declarations]-          defaults <- tcDefaults default_decls ;-          updGblEnv (\gbl -> gbl { tcg_default = defaults }) $ do {-+          defaults <- tcDefaultDecls default_decls+          ; extendDefaultEnvWithLocalDefaults defaults $ do {            -- Careful to quit now in case there were instance errors, so that           -- the deriving errors don't pile up as well.@@ -1916,7 +1940,7 @@     { traceTc "checkMain found" (ppr main_name)     ; (io_ty, res_ty) <- getIOType     ; let loc = getSrcSpan main_name-          main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name))+          main_expr_rn = L (noAnnSrcSpan loc) (mkHsVar (L (noAnnSrcSpan loc) main_name))     ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $                                tcCheckMonoExpr main_expr_rn io_ty @@ -1955,13 +1979,11 @@ setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a) setMainCtxt main_name io_ty thing_inside   = setSrcSpan (getSrcSpan main_name) $-    addErrCtxt main_ctxt              $+    addErrCtxt (MainCtxt main_name)   $     checkConstraints skol_info [] []  $  -- Builds an implication if necessary     thing_inside                         -- e.g. with -fdefer-type-errors   where     skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty []-    main_ctxt = text "When checking the type of the"-                <+> ppMainFn (nameOccName main_name)  {- Note [Dealing with main] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2055,7 +2077,26 @@ There is also some similar (probably dead) logic in GHC.Rename.Env which says it was added for External Core which faced a similar issue. +Note [runTcInteractive module graph]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `withInteractiveModuleNode` function sets up the module graph which contains+the interactive module used by `runTcInteractive`.++The module graph is essentially the ambient module graph which is set up when+ghci loads a module using `load`, with the addition of the interactive module (Ghci<N>),+which imports the parts specified by the `InteractiveImports`.++Therefore `downsweepInteractiveImports` presumes that any import which is+determined to be from the home module is already present in the module graph.+This saves resummarising and performing the whole downsweep again if it's already been+done.++On the other hand, when GHCi starts up, and no modules have been loaded yet, the+module graph will be empty. Therefore `downsweepInteractiveImports` will perform+for the unit portion of the graph, if it's not already been performed.++ ********************************************************* *                                                       *                 GHCi stuff@@ -2063,12 +2104,20 @@ ********************************************************* -} +-- See Note [runTcInteractive module graph]+withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a+withInteractiveModuleNode hsc_env thing_inside = do+  mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env)+  updTopEnv (setModuleGraph mg) thing_inside++ runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside   = initTcInteractive hsc_env $ withTcPlugins hsc_env $     withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $+    withInteractiveModuleNode hsc_env $     do { traceTc "setInteractiveContext" $             vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))                  , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts))@@ -2077,17 +2126,23 @@                                                  , let local_gres = filter isLocalGRE gres                                                  , not (null local_gres) ]) ] -       ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface-                                          : dep_orphs (mi_deps iface))-                                 (loadSrcInterface (text "runTcInteractive") m-                                                   NotBoot mb_pkg)+       ; let getOrphansForModuleName m mb_pkg = do+              iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg+              pure $ mi_module iface : dep_orphs (mi_deps iface) +             getOrphansForModule m = do+              iface <- loadModuleInterface (text "runTcInteractive") m+              pure $ mi_module iface : dep_orphs (mi_deps iface)+        ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->             case i of                   -- force above: see #15111-                IIModule n -> getOrphans n NoPkgQual-                IIDecl i   -> getOrphans (unLoc (ideclName i))+                IIModule n -> getOrphansForModule n+                IIDecl i   -> getOrphansForModuleName (unLoc (ideclName i))                                          (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) ++       ; (home_insts, home_fam_insts) <- liftIO $ UnitEnv.hugAllInstances (hsc_unit_env hsc_env)+        ; let imports = emptyImportAvails { imp_orphs = orphs }               upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env')@@ -2111,8 +2166,6 @@         ; updEnvs upd_envs thing_inside }   where-    (home_insts, home_fam_insts) = hptAllInstances hsc_env-     icxt                     = hsc_IC hsc_env     (ic_insts, ic_finsts)    = ic_instances icxt     (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)@@ -2575,17 +2628,18 @@     failIfErrsM ;      -- Typecheck the expression-    ((tclvl, res_ty), lie)+    ((tclvl, (_tc_expr, res_ty)), lie)           <- captureTopConstraints $              pushTcLevelM          $-             tcInferSigma inst rn_expr ;+             (if inst then tcInferRho rn_expr+                      else tcInferSigma rn_expr);      -- Generalise     uniq <- newUnique ;     let { fresh_it = itName uniq (getLocA rdr_expr) } ;     ((qtvs, dicts, _, _), residual)          <- captureConstraints $-            simplifyInfer tclvl infer_mode+            simplifyInfer TopLevel tclvl infer_mode                           []    {- No sig vars -}                           [(fresh_it, res_ty)]                           lie ;@@ -2669,6 +2723,16 @@   where     zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } ++tcRnTypeSkolemising :: HscEnv+                    -> LHsType GhcPs+                    -> IO (Messages TcRnMessage, Maybe (Type, Kind))+-- tcRnTypeSkolemising skolemisese any free unification variables,+-- and normalises the type+tcRnTypeSkolemising env ty+  = do { skol_tv_ref <- liftIO (newIORef [])+       ; tcRnType env (SkolemiseFlexi skol_tv_ref) True ty }+ -- tcRnType just finds the kind of a type tcRnType :: HscEnv          -> ZonkFlexi@@ -2857,7 +2921,7 @@          let rdr_names = dataTcOccs rdr_name        ; names_s <- mapM lookupInfoOccRn rdr_names        ; let names = concat names_s-       ; when (null names) (addErrTc $ mkTcRnNotInScope rdr_name NotInScope)+       ; when (null names) (addErrTc $ TcRnNotInScope NotInScope rdr_name)        ; return names }  tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
compiler/GHC/Tc/Plugin.hs view
@@ -1,4 +1,3 @@- -- | 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.@@ -15,6 +14,7 @@         lookupOrig,          -- * Looking up Names in the typechecking environment+        lookupTHName,         tcLookupGlobal,         tcLookupTyCon,         tcLookupDataCon,@@ -66,7 +66,7 @@ import GHC.Tc.Utils.Monad      ( TcGblEnv, TcLclEnv, TcPluginM                                , unsafeTcPluginTcM                                , liftIO, traceTc )-import GHC.Tc.Types.Constraint ( Ct, CtEvidence(..) )+import GHC.Tc.Types.Constraint ( Ct, CtEvidence(..), GivenCtEvidence(..) ) import GHC.Tc.Types.CtLoc      ( CtLoc )  import GHC.Tc.Utils.TcMType    ( TcTyVar, TcType )@@ -74,6 +74,7 @@ import GHC.Tc.Types.Evidence   ( CoercionHole, EvTerm(..)                                , EvExpr, EvBindsVar, EvBind, mkGivenEvBind ) import GHC.Types.Var           ( EvVar )+import GHC.Plugins             ( thNameToGhcNameIO )  import GHC.Unit.Module    ( ModuleName, Module ) import GHC.Types.Name     ( OccName, Name )@@ -90,6 +91,7 @@ import GHC.Types.Unique     ( Unique ) import GHC.Types.PkgQual    ( PkgQual ) +import qualified GHC.Boot.TH.Syntax as TH  -- | Perform some IO, typically to interact with an external tool. tcPluginIO :: IO a -> TcPluginM a@@ -99,7 +101,6 @@ tcPluginTrace :: String -> SDoc -> TcPluginM () tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) - findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do     hsc_env <- getTopEnv@@ -108,6 +109,13 @@ lookupOrig :: Module -> OccName -> TcPluginM Name lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod +-- | Resolve a @template-haskell@ 'TH.Name' to a GHC 'Name'.+--+-- @since 9.14.1+lookupTHName :: TH.Name -> TcPluginM (Maybe Name)+lookupTHName th = do+    nc <- hsc_NC <$> getTopEnv+    tcPluginIO $ thNameToGhcNameIO nc th  tcLookupGlobal :: Name -> TcPluginM TyThing tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal@@ -176,7 +184,8 @@ newGiven tc_evbinds loc pty evtm = do    new_ev <- newEvVar pty    setEvBind tc_evbinds $ mkGivenEvBind new_ev (EvExpr evtm)-   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }+   return $ CtGiven $+     GivenCt { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }  -- | Create a fresh evidence variable. --@@ -187,7 +196,7 @@ -- | Create a fresh coercion hole. -- This should only be invoked within 'tcPluginSolve'. newCoercionHole :: PredType -> TcPluginM CoercionHole-newCoercionHole = unsafeTcPluginTcM . TcM.newVanillaCoercionHole+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole  -- | Bind an evidence variable. --
compiler/GHC/Tc/Solver.hs view
@@ -4,4123 +4,2244 @@        InferMode(..), simplifyInfer, findInferredDiff,        growThetaTyVars,        simplifyAmbiguityCheck,-       simplifyDefault,-       simplifyTop, simplifyTopImplic,-       simplifyInteractive,-       solveEqualities,-       pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX,-       reportUnsolvedEqualities,-       simplifyWantedsTcM,-       tcCheckGivens,-       tcCheckWanteds,-       tcNormalise,--       captureTopConstraints,--       simplifyTopWanteds,--       promoteTyVarSet, simplifyAndEmitFlatConstraints,--       -- For Rules we need these-       solveWanteds,-       approximateWC--  ) where--import GHC.Prelude--import GHC.Tc.Errors-import GHC.Tc.Errors.Types-import GHC.Tc.Types.Evidence-import GHC.Tc.Solver.Solve   ( solveSimpleGivens, solveSimpleWanteds )-import GHC.Tc.Solver.Dict    ( makeSuperClasses, solveCallStack )-import GHC.Tc.Solver.Rewrite ( rewriteType )-import GHC.Tc.Utils.Unify-import GHC.Tc.Utils.TcMType as TcM-import GHC.Tc.Utils.Monad   as TcM-import GHC.Tc.Zonk.TcType     as TcM-import GHC.Tc.Solver.InertSet-import GHC.Tc.Solver.Monad  as TcS-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.CtLoc( mkGivenLoc )-import GHC.Tc.Instance.FunDeps-import GHC.Tc.Types.Origin-import GHC.Tc.Utils.TcType--import GHC.Core.Class-import GHC.Core.Reduction( Reduction, reductionCoercion )-import GHC.Core-import GHC.Core.DataCon-import GHC.Core.Make-import GHC.Core.Coercion( mkNomReflCo, isReflCo )-import GHC.Core.Unify    ( tcMatchTyKis )-import GHC.Core.Predicate-import GHC.Core.Type-import GHC.Core.Ppr-import GHC.Core.TyCon    ( TyConBinder, isTypeFamilyTyCon )--import GHC.Types.Name-import GHC.Types.DefaultEnv ( ClassDefaults (..), defaultList )-import GHC.Types.Unique.Set-import GHC.Types.Id--import GHC.Builtin.Utils-import GHC.Builtin.Names-import GHC.Builtin.Types--import GHC.Types.TyThing ( MonadThings(lookupId) )-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Basic-import GHC.Types.Id.Make  ( unboxedUnitExpr )-import GHC.Types.Error--import GHC.Driver.DynFlags-import GHC.Unit.Module ( getModule )--import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Utils.Outputable--import GHC.Data.FastString-import GHC.Data.List.SetOps-import GHC.Data.Bag--import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Control.Monad.Trans.Class        ( lift )-import Control.Monad.Trans.State.Strict ( StateT(runStateT), put )-import Data.Foldable      ( toList, traverse_ )-import Data.List          ( partition, intersect )-import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )-import qualified Data.List.NonEmpty as NE-import GHC.Data.Maybe     ( isJust, mapMaybe, catMaybes )-import Data.Monoid     ( First(..) )--{--*********************************************************************************-*                                                                               *-*                           External interface                                  *-*                                                                               *-*********************************************************************************--}--captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)--- (captureTopConstraints m) runs m, and returns the type constraints it--- generates plus the constraints produced by static forms inside.--- If it fails with an exception, it reports any insolubles--- (out of scope variables) before doing so------ captureTopConstraints is used exclusively by GHC.Tc.Module at the top--- level of a module.------ Importantly, if captureTopConstraints propagates an exception, it--- reports any insoluble constraints first, lest they be lost--- altogether.  This is important, because solveEqualities (maybe--- other things too) throws an exception without adding any error--- messages; it just puts the unsolved constraints back into the--- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors]--- #16376 is an example of what goes wrong if you don't do this.------ NB: the caller should bring any environments into scope before--- calling this, so that the reportUnsolved has access to the most--- complete GlobalRdrEnv-captureTopConstraints thing_inside-  = do { static_wc_var <- TcM.newTcRef emptyWC ;-       ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $-                          TcM.tryCaptureConstraints thing_inside-       ; stWC <- TcM.readTcRef static_wc_var--       -- See GHC.Tc.Utils.Monad Note [Constraints and errors]-       -- If the thing_inside threw an exception, but generated some insoluble-       -- constraints, report the latter before propagating the exception-       -- Otherwise they will be lost altogether-       ; case mb_res of-           Just res -> return (res, lie `andWC` stWC)-           Nothing  -> do { _ <- simplifyTop lie; failM } }-                -- This call to simplifyTop is the reason-                -- this function is here instead of GHC.Tc.Utils.Monad-                -- We call simplifyTop so that it does defaulting-                -- (esp of runtime-reps) before reporting errors--simplifyTopImplic :: Bag Implication -> TcM ()-simplifyTopImplic implics-  = do { empty_binds <- simplifyTop (mkImplicWC implics)--       -- Since all the inputs are implications the returned bindings will be empty-       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)--       ; return () }--simplifyTop :: WantedConstraints -> TcM (Bag EvBind)--- Simplify top-level constraints--- Usually these will be implications,--- but when there is nothing to quantify we don't wrap--- in a degenerate implication, so we do that here instead-simplifyTop wanteds-  = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds-       ; ((final_wc, unsafe_ol), binds1) <- runTcS $-            do { final_wc <- simplifyTopWanteds wanteds-               ; unsafe_ol <- getSafeOverlapFailures-               ; return (final_wc, unsafe_ol) }-       ; traceTc "End simplifyTop }" empty--       ; binds2 <- reportUnsolved final_wc--       ; traceTc "reportUnsolved (unsafe overlapping) {" empty-       ; unless (isEmptyBag unsafe_ol) $ do {-           -- grab current error messages and clear, warnAllUnsolved will-           -- update error messages which we'll grab and then restore saved-           -- messages.-           ; errs_var  <- getErrsVar-           ; saved_msg <- TcM.readTcRef errs_var-           ; TcM.writeTcRef errs_var emptyMessages--           ; warnAllUnsolved $ emptyWC { wc_simple = fmap CDictCan unsafe_ol }--           ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var-           ; TcM.writeTcRef errs_var saved_msg-           ; recordUnsafeInfer (mkMessages whyUnsafe)-           }-       ; traceTc "reportUnsolved (unsafe overlapping) }" empty--       ; return (evBindMapBinds binds1 `unionBags` binds2) }--pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a--- Push level, and solve all resulting equalities--- If there are any unsolved equalities, report them--- and fail (in the monad)------ Panics if we solve any non-equality constraints.  (In runTCSEqualities--- we use an error thunk for the evidence bindings.)-pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside-  = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX-                                      "pushLevelAndSolveEqualities" thing_inside-       ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted-       ; return res }--pushLevelAndSolveEqualitiesX :: String -> TcM a-                             -> TcM (TcLevel, WantedConstraints, a)--- Push the level, gather equality constraints, and then solve them.--- Returns any remaining unsolved equalities.--- Does not report errors.------ Panics if we solve any non-equality constraints.  (In runTCSEqualities--- we use an error thunk for the evidence bindings.)-pushLevelAndSolveEqualitiesX callsite thing_inside-  = do { traceTc "pushLevelAndSolveEqualitiesX {" (text "Called from" <+> text callsite)-       ; (tclvl, (wanted, res))-            <- pushTcLevelM $-               do { (res, wanted) <- captureConstraints thing_inside-                  ; wanted <- runTcSEqualities (simplifyTopWanteds wanted)-                  ; return (wanted,res) }-       ; traceTc "pushLevelAndSolveEqualities }" (vcat [ text "Residual:" <+> ppr wanted-                                                       , text "Level:" <+> ppr tclvl ])-       ; return (tclvl, wanted, res) }---- | Type-check a thing that emits only equality constraints, solving any--- constraints we can and re-emitting constraints that we can't.--- Use this variant only when we'll get another crack at it later--- See Note [Failure in local type signatures]------ Panics if we solve any non-equality constraints.  (In runTCSEqualities--- we use an error thunk for the evidence bindings.)-solveEqualities :: String -> TcM a -> TcM a-solveEqualities callsite thing_inside-  = do { traceTc "solveEqualities {" (text "Called from" <+> text callsite)-       ; (res, wanted)   <- captureConstraints thing_inside-       ; simplifyAndEmitFlatConstraints wanted-            -- simplifyAndEmitFlatConstraints fails outright unless-            --  the only unsolved constraints are soluble-looking-            --  equalities that can float out-       ; traceTc "solveEqualities }" empty-       ; return res }--simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM ()--- See Note [Failure in local type signatures]-simplifyAndEmitFlatConstraints wanted-  = do { -- Solve and zonk to establish the-         -- preconditions for floatKindEqualities-         wanted <- runTcSEqualities (solveWanteds wanted)-       ; wanted <- TcM.liftZonkM $ TcM.zonkWC wanted--       ; traceTc "emitFlatConstraints {" (ppr wanted)-       ; case floatKindEqualities wanted of-           Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted)-                         -- Emit the bad constraints, wrapped in an implication-                         -- See Note [Wrapping failing kind equalities]-                         ; tclvl  <- TcM.getTcLevel-                         ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted-                                        --                  ^^^^^^   |  ^^^^^^^^^^^^^^^^^-                                        -- it's OK to use unkSkol    |  we must increase the TcLevel,-                                        -- because we don't bind     |  as explained in-                                        -- any skolem variables here |  Note [Wrapping failing kind equalities]-                         ; emitImplication implic-                         ; failM }-           Just (simples, errs)-              -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)-                    ; traceTc "emitFlatConstraints }" $-                      vcat [ text "simples:" <+> ppr simples-                           , text "errs:   " <+> ppr errs ]-                      -- Holes and other delayed errors don't need promotion-                    ; emitDelayedErrors errs-                    ; emitSimples simples } }--floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError)--- Float out all the constraints from the WantedConstraints,--- Return Nothing if any constraints can't be floated (captured--- by skolems), or if there is an insoluble constraint, or--- IC_Telescope telescope error--- Precondition 1: we have tried to solve the 'wanteds', both so that---    the ic_status field is set, and because solving can make constraints---    more floatable.--- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities---    is not monadic--- See Note [floatKindEqualities vs approximateWC]-floatKindEqualities wc = float_wc emptyVarSet wc-  where-    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError)-    float_wc trapping_tvs (WC { wc_simple = simples-                              , wc_impl = implics-                              , wc_errors = errs })-      | all is_floatable simples-      = do { (inner_simples, inner_errs)-                <- flatMapBagPairM (float_implic trapping_tvs) implics-           ; return ( simples `unionBags` inner_simples-                    , errs `unionBags` inner_errs) }-      | otherwise-      = Nothing-      where-        is_floatable ct-           | insolubleCt ct = False-           | otherwise      = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs--    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError)-    float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs-                                      , ic_skols = skols, ic_status = status })-      | isInsolubleStatus status-      = Nothing   -- A short cut /plus/ we must keep track of IC_BadTelescope-      | otherwise-      = do { (simples, holes) <- float_wc new_trapping_tvs wanted-           ; when (not (isEmptyBag simples) && given_eqs == MaybeGivenEqs) $-             Nothing-                 -- If there are some constraints to float out, but we can't-                 -- because we don't float out past local equalities-                 -- (c.f GHC.Tc.Solver.approximateWC), then fail-           ; return (simples, holes) }-      where-        new_trapping_tvs = trapping_tvs `extendVarSetList` skols---{- Note [Failure in local type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When kind checking a type signature, we like to fail fast if we can't-solve all the kind equality constraints, for two reasons:--  * A kind-bogus type signature may cause a cascade of knock-on-    errors if we let it pass--  * More seriously, we don't have a convenient term-level place to add-    deferred bindings for unsolved kind-equality constraints.  In-    earlier GHCs this led to un-filled-in coercion holes, which caused-    GHC to crash with "fvProv falls into a hole" See #11563, #11520,-    #11516, #11399--But what about /local/ type signatures, mentioning in-scope type-variables for which there might be 'given' equalities?  For these we-might not be able to solve all the equalities locally. Here's an-example (T15076b):--  class (a ~ b) => C a b-  data SameKind :: k -> k -> Type where { SK :: SameKind a b }--  bar :: forall (a :: Type) (b :: Type).-         C a b => Proxy a -> Proxy b -> ()-  bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y)--Consider the type signature on 'undefined'. It's ill-kinded unless-a~b.  But the superclass of (C a b) means that indeed (a~b). So all-should be well. BUT it's hard to see that when kind-checking the signature-for undefined.  We want to emit a residual (a~b) constraint, to solve-later.--Another possibility is that we might have something like-   F alpha ~ [Int]-where alpha is bound further out, which might become soluble-"later" when we learn more about alpha.  So we want to emit-those residual constraints.--BUT it's no good simply wrapping all unsolved constraints from-a type signature in an implication constraint to solve later. The-problem is that we are going to /use/ that signature, including-instantiate it.  Say we have-     f :: forall a.  (forall b. blah) -> blah2-     f x = <body>-To typecheck the definition of f, we have to instantiate those-foralls.  Moreover, any unsolved kind equalities will be coercion-holes in the type.  If we naively wrap them in an implication like-     forall a. (co1:k1~k2,  forall b.  co2:k3~k4)-hoping to solve it later, we might end up filling in the holes-co1 and co2 with coercions involving 'a' and 'b' -- but by now-we've instantiated the type.  Chaos!--Moreover, the unsolved constraints might be skolem-escape things, and-if we proceed with f bound to a nonsensical type, we get a cascade of-follow-up errors. For example polykinds/T12593, T15577, and many others.--So here's the plan (see tcHsSigType):--* pushLevelAndSolveEqualitiesX: try to solve the constraints--* kindGeneraliseSome: do kind generalisation--* buildTvImplication: build an implication for the residual, unsolved-  constraint--* simplifyAndEmitFlatConstraints: try to float out every unsolved equality-  inside that implication, in the hope that it constrains only global-  type variables, not the locally-quantified ones.--  * If we fail, or find an insoluble constraint, emit the implication,-    so that the errors will be reported, and fail.--  * If we succeed in floating all the equalities, promote them and-    re-emit them as flat constraint, not wrapped at all (since they-    don't mention any of the quantified variables.--* Note that this float-and-promote step means that anonymous-  wildcards get floated to top level, as we want; see-  Note [Checking partial type signatures] in GHC.Tc.Gen.HsType.--All this is done:--* In GHC.Tc.Gen.HsType.tcHsSigType, as above--* solveEqualities. Use this when there no kind-generalisation-  step to complicate matters; then we don't need to push levels,-  and can solve the equalities immediately without needing to-  wrap it in an implication constraint.  (You'll generally see-  a kindGeneraliseNone nearby.)--* In GHC.Tc.TyCl and GHC.Tc.TyCl.Instance; see calls to-  pushLevelAndSolveEqualitiesX, followed by quantification, and-  then reportUnsolvedEqualities.--  NB: we call reportUnsolvedEqualities before zonkTcTypeToType-  because the latter does not expect to see any un-filled-in-  coercions, which will happen if we have unsolved equalities.-  By calling reportUnsolvedEqualities first, which fails after-  reporting errors, we avoid that happening.--See also #18062, #11506--Note [Wrapping failing kind equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In simplifyAndEmitFlatConstraints, if we fail to get down to simple-flat constraints we will-* re-emit the constraints so that they are reported-* fail in the monad-But there is a Terrible Danger that, if -fdefer-type-errors is on, and-we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll-report only a warning and proceed with compilation.  But if we ever fail-in the monad it should be fatal; we should report an error and stop after-the type checker.  If not, chaos results: #19142.--Our solution is this:-* Even with -fdefer-type-errors, inside an implication with no place for-  value bindings (ic_binds = CoEvBindsVar), report failing equalities as-  errors.  We have to do this anyway; see GHC.Tc.Errors-  Note [Failing equalities with no evidence bindings].--* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication-  to wrap the failing constraint in a degenerate implication (no-  skolems, no theta), with ic_binds = CoEvBindsVar.  This setting of-  `ic_binds` means that any failing equalities will lead to an-  error not a warning, irrespective of -fdefer-type-errors: see-  Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors,-  and `maybeSwitchOffDefer` in that module.--  We still take care to bump the TcLevel of the implication.  Partly,-  that ensures that nested implications have increasing level numbers-  which seems nice.  But more specifically, suppose the outer level-  has a Given `(C ty)`, which has pending (not-yet-expanded)-  superclasses. Consider what happens when we process this implication-  constraint (which we have re-emitted) in that context:-    - in the inner implication we'll call `getPendingGivenScs`,-    - we /do not/ want to get the `(C ty)` from the outer level,-    lest we try to add an evidence term for the superclass,-    which we can't do because we have specifically set-    `ic_binds` = `CoEvBindsVar`.-    - as `getPendingGivenSCcs is careful to only get Givens from-    the /current/ level, and we bumped the `TcLevel` of the implication,-    we're OK.--  TL;DR: bump the `TcLevel` when creating the nested implication.-  If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043).---We re-emit the implication rather than reporting the errors right now,-so that the error messages are improved by other solving and defaulting.-e.g. we prefer-    Cannot match 'Type->Type' with 'Type'-to  Cannot match 'Type->Type' with 'TYPE r0'---Note [floatKindEqualities vs approximateWC]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-floatKindEqualities and approximateWC are strikingly similar to each-other, but--* floatKindEqualites tries to float /all/ equalities, and fails if-  it can't, or if any implication is insoluble.-* approximateWC just floats out any constraints-  (not just equalities) that can float; it never fails.--}---reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel-                         -> WantedConstraints -> TcM ()--- Reports all unsolved wanteds provided; fails in the monad if there are any.------ The provided SkolemInfo and [TcTyVar] arguments are used in an implication to--- provide skolem info for any errors.-reportUnsolvedEqualities skol_info skol_tvs tclvl wanted-  = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted--report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel-                           -> WantedConstraints -> TcM ()-report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted-  | isEmptyWC wanted-  = return ()--  | otherwise  -- NB: we build an implication /even if skol_tvs is empty/,-               -- just to ensure that our level invariants hold, specifically-               -- (WantedInv).  See Note [TcLevel invariants].-  = checkNoErrs $   -- Fail-    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted-       ; reportAllUnsolved (mkImplicWC (unitBag implic)) }----- | Simplify top-level constraints, but without reporting any unsolved--- constraints nor unsafe overlapping.-simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints-simplifyTopWanteds wanteds-  = do { -- Solve the constraints-         wc_first_go <- nestTcS (solveWanteds wanteds)--         -- Now try defaulting:-         -- see Note [Top-level Defaulting Plan]-       ; tryDefaulting wc_first_go }-----------------------------tryDefaulting :: WantedConstraints -> TcS WantedConstraints-tryDefaulting wc- = do { dflags <- getDynFlags-      ; traceTcS "tryDefaulting:before" (ppr wc)-      ; wc1 <- tryTyVarDefaulting dflags wc-      ; wc2 <- tryConstraintDefaulting wc1-      ; wc3 <- tryTypeClassDefaulting wc2-      ; wc4 <- tryUnsatisfiableGivens wc3-      ; traceTcS "tryDefaulting:after" (ppr wc4)-      ; return wc4 }--solveAgainIf :: Bool -> WantedConstraints -> TcS WantedConstraints--- If the Bool is true, solve the wanted constraints again--- See Note [Must simplify after defaulting]-solveAgainIf False wc = return wc-solveAgainIf True  wc = nestTcS (solveWanteds wc)-----------------------------tryTyVarDefaulting  :: DynFlags -> WantedConstraints -> TcS WantedConstraints-tryTyVarDefaulting dflags wc-  | isEmptyWC wc-  = return wc-  | insolubleWC wc-  , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]-  = return wc-  | otherwise-  = do { -- Need to zonk first, as the WantedConstraints are not yet zonked.-       ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)-       ; let defaultable_tvs = filter can_default free_tvs-             can_default tv-               =   isTyVar tv-                   -- Weed out coercion variables.--                && isMetaTyVar tv-                   -- Weed out runtime-skolems in GHCi, which we definitely-                   -- shouldn't try to default.--                && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc)-                   -- Weed out variables for which defaulting would be unhelpful,-                   -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk].--       ; unification_s <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects-       ; solveAgainIf (or unification_s) wc }-             -- solveAgainIf: see Note [Must simplify after defaulting]--------------------------------- | If an implication contains a Given of the form @Unsatisfiable msg@,--- use it to solve all Wanteds within the implication.--- See point (C) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors.------ This does a complete walk over the implication tree.-tryUnsatisfiableGivens :: WantedConstraints -> TcS WantedConstraints-tryUnsatisfiableGivens wc =-  do { (final_wc, did_work) <- (`runStateT` False) $ go_wc wc-     ; solveAgainIf did_work final_wc }-  where-    go_wc (WC { wc_simple = wtds, wc_impl = impls, wc_errors = errs })-      = do impls' <- mapMaybeBagM go_impl impls-           return $ WC { wc_simple = wtds, wc_impl = impls', wc_errors = errs }-    go_impl impl-      | isSolvedStatus (ic_status impl)-      = return $ Just impl-      -- Is there a Given with type "Unsatisfiable msg"?-      -- If so, use it to solve all other Wanteds.-      | unsat_given:_ <- mapMaybe unsatisfiableEv_maybe (ic_given impl)-      = do { put True-           ; lift $ solveImplicationUsingUnsatGiven unsat_given impl }-      -- Otherwise, recurse.-      | otherwise-      = do { wcs' <- go_wc (ic_wanted impl)-           ; lift $ setImplicationStatus $ impl { ic_wanted = wcs' } }---- | Is this evidence variable the evidence for an 'Unsatisfiable' constraint?------ If so, return the variable itself together with the error message type.-unsatisfiableEv_maybe :: EvVar -> Maybe (EvVar, Type)-unsatisfiableEv_maybe v = (v,) <$> isUnsatisfiableCt_maybe (idType v)---- | We have an implication with an 'Unsatisfiable' Given; use that Given to--- solve all the other Wanted constraints, including those nested within--- deeper implications.-solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS (Maybe Implication)-solveImplicationUsingUnsatGiven-  unsat_given@(given_ev,_)-  impl@(Implic { ic_wanted = wtd, ic_tclvl = tclvl, ic_binds = ev_binds_var, ic_need_inner = inner })-  | isCoEvBindsVar ev_binds_var-  -- We can't use Unsatisfiable evidence in kinds.-  -- See Note [Coercion evidence only] in GHC.Tc.Types.Evidence.-  = return $ Just impl-  | otherwise-  = do { wcs <- nestImplicTcS ev_binds_var tclvl $ go_wc wtd-       ; setImplicationStatus $-         impl { ic_wanted = wcs-              , ic_need_inner = inner `extendVarSet` given_ev } }-  where-    go_wc :: WantedConstraints -> TcS WantedConstraints-    go_wc wc@(WC { wc_simple = wtds, wc_impl = impls })-      = do { mapBagM_ go_simple wtds-           ; impls <- mapMaybeBagM (solveImplicationUsingUnsatGiven unsat_given) impls-           ; return $ wc { wc_simple = emptyBag, wc_impl = impls } }-    go_simple :: Ct -> TcS ()-    go_simple ct = case ctEvidence ct of-      CtWanted { ctev_pred = pty, ctev_dest = dst }-        -> do { ev_expr <- unsatisfiableEvExpr unsat_given pty-              ; setWantedEvTerm dst EvNonCanonical $ EvExpr ev_expr }-      _ -> return ()---- | Create an evidence expression for an arbitrary constraint using--- evidence for an "Unsatisfiable" Given.------ See Note [Evidence terms from Unsatisfiable Givens]-unsatisfiableEvExpr :: (EvVar, ErrorMsgType) -> PredType -> TcS EvExpr-unsatisfiableEvExpr (unsat_ev, given_msg) wtd_ty-  = do { mod <- getModule-         -- If we're typechecking GHC.TypeError, return a bogus expression;-         -- it's only used for the ambiguity check, which throws the evidence away anyway.-         -- This avoids problems with circularity; where we are trying to look-         -- up the "unsatisfiable" Id while we are in the middle of typechecking it.-       ; if mod == gHC_INTERNAL_TYPEERROR then return (Var unsat_ev) else-    do { unsatisfiable_id <- tcLookupId unsatisfiableIdName--         -- See Note [Evidence terms from Unsatisfiable Givens]-         -- for a description of what evidence term we are constructing here.--       ; let -- (##) -=> wtd_ty-             fun_ty = mkFunTy visArgConstraintLike ManyTy unboxedUnitTy wtd_ty-             mkDictBox = case boxingDataCon fun_ty of-               BI_Box { bi_data_con = mkDictBox } -> mkDictBox-               _ -> pprPanic "unsatisfiableEvExpr: no DictBox!" (ppr wtd_ty)-             dictBox = dataConTyCon mkDictBox-       ; ev_bndr <- mkSysLocalM (fsLit "ct") ManyTy fun_ty-             -- Dict ((##) -=> wtd_ty)-       ; let scrut_ty = mkTyConApp dictBox [fun_ty]-             -- unsatisfiable @{LiftedRep} @given_msg @(Dict ((##) -=> wtd_ty)) unsat_ev-             scrut =-               mkCoreApps (Var unsatisfiable_id)-                 [ Type liftedRepTy-                 , Type given_msg-                 , Type scrut_ty-                 , Var unsat_ev ]-             -- case scrut of { MkDictBox @((##) -=> wtd_ty)) ct -> ct (# #) }-             ev_expr =-               mkWildCase scrut (unrestricted $ scrut_ty) wtd_ty-               [ Alt (DataAlt mkDictBox) [ev_bndr] $-                   mkCoreApps (Var ev_bndr) [unboxedUnitExpr]-               ]-        ; return ev_expr } }--{- Note [Evidence terms from Unsatisfiable Givens]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An Unsatisfiable Given constraint, of the form [G] Unsatisfiable msg, should be-able to solve ANY Wanted constraint whatsoever.--Recall that we have--  unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep)-                .  Unsatisfiable msg => a--We want to use this function, together with the evidence-[G] unsat_ev :: Unsatisfiable msg, to solve any other constraint [W] wtd_ty.--We could naively think that a valid evidence term for the Wanted might be:--  wanted_ev = unsatisfiable @{rep} @msg @wtd_ty unsat_ev--Unfortunately, this is a kind error: "wtd_ty :: CONSTRAINT rep", but-"unsatisfiable" expects the third type argument to be of kind "TYPE rep".--Instead, we use a boxing data constructor to box the constraint into a type.-In the end, we construct the following evidence for the implication:--  [G] unsat_ev :: Unsatisfiable msg-    ==>-      [W] wtd_ev :: wtd_ty--  wtd_ev =-    case unsatisfiable @{LiftedRep} @msg @(Dict ((##) -=> wtd_ty)) unsat_ev of-      MkDictBox ct -> ct (# #)--Note that we play the same trick with the function arrow -=> that we did-in order to define "unsatisfiable" in terms of "unsatisfiableLifted", as described-in Note [The Unsatisfiable representation-polymorphism trick] in base:GHC.TypeError.-This allows us to indirectly box constraints with different representations-(such as primitive equality constraints).--}---- | A 'TcS' action which can may solve a `Ct`-type CtDefaultingStrategy = Ct -> TcS Bool-  -- True <=> I solved the constraint-----------------------------------tryConstraintDefaulting :: WantedConstraints -> TcS WantedConstraints--- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-tryConstraintDefaulting wc-  | isEmptyWC wc-  = return wc-  | otherwise-  = do { (n_unifs, better_wc) <- reportUnifications (go_wc wc)-         -- We may have done unifications; so solve again-       ; solveAgainIf (n_unifs > 0) better_wc }-  where-    go_wc :: WantedConstraints -> TcS WantedConstraints-    go_wc wc@(WC { wc_simple = simples, wc_impl = implics })-      = do { mb_simples <- mapMaybeBagM go_simple simples-           ; mb_implics <- mapMaybeBagM go_implic implics-           ; return (wc { wc_simple = mb_simples, wc_impl   = mb_implics }) }--    go_simple :: Ct -> TcS (Maybe Ct)-    go_simple ct = do { solved <- tryCtDefaultingStrategy ct-                      ; if solved then return Nothing-                                  else return (Just ct) }--    go_implic :: Implication -> TcS (Maybe Implication)-    -- The Maybe is because solving the CallStack constraint-    -- may well allow us to discard the implication entirely-    go_implic implic-      | isSolvedStatus (ic_status implic)-      = return (Just implic)  -- Nothing to solve inside here-      | otherwise-      = do { wanteds <- setEvBindsTcS (ic_binds implic) $-                        -- defaultCallStack sets a binding, so-                        -- we must set the correct binding group-                        go_wc (ic_wanted implic)-           ; setImplicationStatus (implic { ic_wanted = wanteds }) }--tryCtDefaultingStrategy :: CtDefaultingStrategy--- The composition of all the CtDefaultingStrategies we want-tryCtDefaultingStrategy-  = foldr1 combineStrategies-    [ defaultCallStack-    , defaultExceptionContext-    , defaultEquality ]---- | Default @ExceptionContext@ constraints to @emptyExceptionContext@.-defaultExceptionContext :: CtDefaultingStrategy-defaultExceptionContext ct-  | ClassPred cls tys <- classifyPredType (ctPred ct)-  , isJust (isExceptionContextPred cls tys)-  = do { warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct)-       ; empty_ec_id <- lookupId emptyExceptionContextName-       ; let ev = ctEvidence ct-             ev_tm = mkEvCast (Var empty_ec_id) (wrapIP (ctEvPred ev))-       ; setEvBindIfWanted ev EvCanonical ev_tm-         -- EvCanonical: see Note [CallStack and ExecptionContext hack]-         --              in GHC.Tc.Solver.Dict-       ; return True }-  | otherwise-  = return False---- | Default any remaining @CallStack@ constraints to empty @CallStack@s.--- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-defaultCallStack :: CtDefaultingStrategy-defaultCallStack ct-  | ClassPred cls tys <- classifyPredType (ctPred ct)-  , isJust (isCallStackPred cls tys)-  = do { solveCallStack (ctEvidence ct) EvCsEmpty-       ; return True }-  | otherwise-  = return False--defaultEquality :: CtDefaultingStrategy--- See Note [Defaulting equalities]-defaultEquality ct-  | EqPred NomEq ty1 ty2 <- classifyPredType (ctPred ct)-  = do { -- Remember: `ct` may not be zonked;-         -- see (DE3) in Note [Defaulting equalities]-         z_ty1 <- TcS.zonkTcType ty1-       ; z_ty2 <- TcS.zonkTcType ty2--       -- Now see if either LHS or RHS is a bare type variable-       -- You might think the type variable will only be on the LHS-       -- but with a type function we might get   F t1 ~ alpha-       ; case (getTyVar_maybe z_ty1, getTyVar_maybe z_ty2) of-           (Just z_tv1, _) -> try_default_tv z_tv1 z_ty2-           (_, Just z_tv2) -> try_default_tv z_tv2 z_ty1-           _               -> return False }-  | otherwise-  = return False--  where-    try_default_tv lhs_tv rhs_ty-      | MetaTv { mtv_info = info, mtv_tclvl = lvl } <- tcTyVarDetails lhs_tv-      , tyVarKind lhs_tv `tcEqType` typeKind rhs_ty-      , checkTopShape info rhs_ty-      -- Do not test for touchability of lhs_tv; that is the whole point!-      -- See (DE2) in Note [Defaulting equalities]-      = do { traceTcS "defaultEquality 1" (ppr lhs_tv $$ ppr rhs_ty)--           -- checkTyEqRhs: check that we can in fact unify lhs_tv := rhs_ty-           -- See Note [Defaulting equalities]-           --   LC_Promote: promote deeper unification variables (DE4)-           --   LC_Promote True: ...including under type families (DE5)-           ; let flags :: TyEqFlags ()-                 flags = TEF { tef_foralls  = False-                             , tef_fam_app  = TEFA_Recurse-                             , tef_lhs      = TyVarLHS lhs_tv-                             , tef_unifying = Unifying info lvl (LC_Promote True)-                             , tef_occurs   = cteInsolubleOccurs }-           ; res :: PuResult () Reduction <- wrapTcS (checkTyEqRhs flags rhs_ty)--           ; case res of-               PuFail {}   -> cant_default_tv "checkTyEqRhs"-               PuOK _ redn -> assertPpr (isReflCo (reductionCoercion redn)) (ppr redn) $-                               -- With TEFA_Recurse we never get any reductions-                              default_tv }-      | otherwise-      = cant_default_tv "fall through"--      where-        cant_default_tv msg-          = do { traceTcS ("defaultEquality fails: " ++ msg) $-                 vcat [ ppr lhs_tv <+> char '~' <+>  ppr rhs_ty-                      , ppr (tyVarKind lhs_tv)-                      , ppr (typeKind rhs_ty) ]-               ; return False }--        -- All tests passed: do the unification-        default_tv-          = do { traceTcS "defaultEquality success:" (ppr rhs_ty)-               ; unifyTyVar lhs_tv rhs_ty  -- NB: unifyTyVar adds to the-                                           -- TcS unification counter-               ; setEvBindIfWanted (ctEvidence ct) EvCanonical $-                 evCoercion (mkNomReflCo rhs_ty)-               ; return True }--combineStrategies :: CtDefaultingStrategy -> CtDefaultingStrategy -> CtDefaultingStrategy-combineStrategies default1 default2 ct-  = do { solved <- default1 ct-       ; case solved of-           True  -> return True  -- default1 solved it!-           False -> default2 ct  -- default1 failed, try default2-       }---{- Note [When to do type-class defaulting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC-was false, on the grounds that defaulting can't help solve insoluble-constraints.  But if we *don't* do defaulting we may report a whole-lot of errors that would be solved by defaulting; these errors are-quite spurious because fixing the single insoluble error means that-defaulting happens again, which makes all the other errors go away.-This is jolly confusing: #9033.--So it seems better to always do type-class defaulting.--However, always doing defaulting does mean that we'll do it in-situations like this (#5934):-   run :: (forall s. GenST s) -> Int-   run = fromInteger 0-We don't unify the return type of fromInteger with the given function-type, because the latter involves foralls.  So we're left with-    (Num alpha, alpha ~ (forall s. GenST s) -> Int)-Now we do defaulting, get alpha := Integer, and report that we can't-match Integer with (forall s. GenST s) -> Int.  That's not totally-stupid, but perhaps a little strange.--Another potential alternative would be to suppress *all* non-insoluble-errors if there are *any* insoluble errors, anywhere, but that seems-too drastic.--Note [Defaulting equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f :: forall a. (forall t. (F t ~ Int) => a -> Int) -> Int--  g :: Int-  g = f id--We'll typecheck-  id :: forall t. (F t ~ Int) => alpha[1] -> Int-where the `alpha[1]` comes from instantiating `f`. So we'll end up-with the implication constraint-   forall[2] t. (F t ~ Int) => alpha[1] ~ Int-And that can't be solved because `alpha` is untouchable under the-equality (F t ~ Int).--This is tiresome, and gave rise to user complaints: #25125 and #25029.-Moreover, in this case there is no good reason not to unify alpha:=Int.-Doing so solves the constraint, and since `alpha` is not otherwise-constrained, it does no harm.  So the new plan is this:--  * For the Wanted constraint-        [W] alpha ~ ty-    if the only reason for not unifying is untouchability, then during-    top-level defaulting, go ahead and unify--In top-level defaulting, we already do several other somewhat-ad-hoc,-but terribly convenient, unifications. This is just one more.--Wrinkles:--(DE1) Note carefully that this does not threaten principal types.-  The original worry about unifying untouchable type variables was this:--     data T a where-       T1 :: T Bool-     f x = case x of T1 -> True--  Should we infer f :: T a -> Bool, or f :: T a -> a.  Both are valid, but-  neither is more general than the other--(DE2) We still can't unify if there is a skolem-escape check, or an occurs check,-  or it it'd mean unifying a TyVarTv with a non-tyvar.  It's only the-  "untouchability test" that we lift.  We can lift it by saying that the innermost-  given equality is at top level.--(DE3) The contraint we are looking at may not be fully zonked; for example,-  an earlier defaulting might have affected it. So we zonk-on-the fly in-  `defaultEquality`.--(DE4) Promotion. Suppose we see  alpha[2] := Maybe beta[4].  We want to promote-  beta[4] to level 2 and unify alpha[2] := Maybe beta'[2].  This is done by-  checkTyEqRhs.--(DE5) Promotion. Suppose we see  alpha[2] := F beta[4], where F is a type-  family. Then we still want to promote beta to beta'[2], and unify. This is-  unusual: more commonly, we don't promote unification variables under a-  type family.  But here we want to.  (This mattered in #25251.)--  Hence the Bool flag on LC_Promote, and its use in `tef_unifying` in-  `defaultEquality`.--Note [Must simplify after defaulting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We may have a deeply buried constraint-    (t:*) ~ (a:Open)-which we couldn't solve because of the kind incompatibility, and 'a' is free.-Then when we default 'a' we can solve the constraint.  And we want to do-that before starting in on type classes.  We MUST do it before reporting-errors, because it isn't an error!  #7967 was due to this.--Note [Top-level Defaulting Plan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have considered two design choices for where/when to apply defaulting.-   (i) Do it in SimplCheck mode only /whenever/ you try to solve some-       simple constraints, maybe deep inside the context of implications.-       This used to be the case in GHC 7.4.1.-   (ii) Do it in a tight loop at simplifyTop, once all other constraints have-        finished. This is the current story.--Option (i) had many disadvantages:-   a) Firstly, it was deep inside the actual solver.-   b) Secondly, it was dependent on the context (Infer a type signature,-      or Check a type signature, or Interactive) since we did not want-      to always start defaulting when inferring (though there is an exception to-      this, see Note [Default while Inferring]).-   c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:-          f :: Int -> Bool-          f x = const True (\y -> let w :: a -> a-                                      w a = const a (y+1)-                                  in w y)-      We will get an implication constraint (for beta the type of y):-               [untch=beta] forall a. 0 => Num beta-      which we really cannot default /while solving/ the implication, since beta is-      untouchable.--Instead our new defaulting story is to pull defaulting out of the solver loop and-go with option (ii), implemented at SimplifyTop. Namely:-     - First, have a go at solving the residual constraint of the whole-       program-     - Try to approximate it with a simple constraint-     - Figure out derived defaulting equations for that simple constraint-     - Go round the loop again if you did manage to get some equations--Now, that has to do with class defaulting. However there exists type variable /kind/-defaulting. Again this is done at the top-level and the plan is:-     - At the top-level, once you had a go at solving the constraint, do-       figure out /all/ the touchable unification variables of the wanted constraints.-     - Apply defaulting to their kinds--More details in Note [DefaultTyVar].--Note [Safe Haskell Overlapping Instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In Safe Haskell, we apply an extra restriction to overlapping instances. The-motive is to prevent untrusted code provided by a third-party, changing the-behavior of trusted code through type-classes. This is due to the global and-implicit nature of type-classes that can hide the source of the dictionary.--Another way to state this is: if a module M compiles without importing another-module N, changing M to import N shouldn't change the behavior of M.--Overlapping instances with type-classes can violate this principle. However,-overlapping instances aren't always unsafe. They are just unsafe when the most-selected dictionary comes from untrusted code (code compiled with -XSafe) and-overlaps instances provided by other modules.--In particular, in Safe Haskell at a call site with overlapping instances, we-apply the following rule to determine if it is a 'unsafe' overlap:-- 1) Most specific instance, I1, defined in an `-XSafe` compiled module.- 2) I1 is an orphan instance or a MPTC.- 3) At least one overlapped instance, Ix, is both:-    A) from a different module than I1-    B) Ix is not marked `OVERLAPPABLE`--This is a slightly involved heuristic, but captures the situation of an-imported module N changing the behavior of existing code. For example, if-condition (2) isn't violated, then the module author M must depend either on a-type-class or type defined in N.--Secondly, when should these heuristics be enforced? We enforced them when the-type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`.-This allows `-XUnsafe` modules to operate without restriction, and for Safe-Haskell inference to infer modules with unsafe overlaps as unsafe.--One alternative design would be to also consider if an instance was imported as-a `safe` import or not and only apply the restriction to instances imported-safely. However, since instances are global and can be imported through more-than one path, this alternative doesn't work.--Note [Safe Haskell Overlapping Instances Implementation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-How is this implemented? It's complicated! So we'll step through it all:-- 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where-    we check if a particular type-class method call is safe or unsafe. We do this-    through the return type, `ClsInstLookupResult`, where the last parameter is a-    list of instances that are unsafe to overlap. When the method call is safe,-    the list is null.-- 2) `GHC.Tc.Solver.Dict.matchClassInst` -- This module drives the instance resolution-    / dictionary generation. The return type is `ClsInstResult`, which either-    says no instance matched, or one found, and if it was a safe or unsafe-    overlap.-- 3) `GHC.Tc.Solver.Dict.tryInstances` -- Takes a dictionary / class constraint and-     tries to resolve it by calling (in part) `matchClassInst`. The resolving-     mechanism has a work list (of constraints) that it process one at a time. If-     the constraint can't be resolved, it's added to an inert set. When compiling-     an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know-     compilation should fail. These are handled as normal constraint resolution-     failures from here-on (see step 6).--     Otherwise, we may be inferring safety (or using `-Wunsafe`), and-     compilation should succeed, but print warnings and/or mark the compiled module-     as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds-     the unsafe (but resolved!) constraint to the `inert_safehask` field of-     `InertCans`.-- 4) `GHC.Tc.Solver.simplifyTop`:-       * Call simplifyTopWanteds, the top-level function for driving the simplifier for-         constraint resolution.--       * Once finished, call `getSafeOverlapFailures` to retrieve the-         list of overlapping instances that were successfully resolved,-         but unsafe. Remember, this is only applicable for generating warnings-         (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy`-         cause compilation failure by not resolving the unsafe constraint at all.--       * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`,-         while for resolved but unsafe overlapping dictionary constraints, call-         `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a-         warning message for the user.--       * In the case of `warnAllUnsolved` for resolved, but unsafe-         dictionary constraints, we collect the generated warning-         message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to-         mark the module we are compiling as unsafe, passing the-         warning message along as the reason.-- 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by-    actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we-    know is the constraint that is unresolved or unsafe. For dictionary, all we-    know is that we need a dictionary of type C, but not what instances are-    available and how they overlap. So we once again call `lookupInstEnv` to-    figure that out so we can generate a helpful error message.-- 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in-      IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`.-- 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling-    `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference-    failed.--Note [No defaulting in the ambiguity check]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When simplifying constraints for the ambiguity check, we use-solveWanteds, not simplifyTopWanteds, so that we do no defaulting.-#11947 was an example:-   f :: Num a => Int -> Int-This is ambiguous of course, but we don't want to default the-(Num alpha) constraint to (Num Int)!  Doing so gives a defaulting-warning, but no error.--Note [Defaulting insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a set of wanteds is insoluble, we have no hope of accepting the-program. Yet we do not stop constraint solving, etc., because we may-simplify the wanteds to produce better error messages. So, once-we have an insoluble constraint, everything we do is just about producing-helpful error messages.--Should we default in this case or not? Let's look at an example (tcfail004):--  (f,g) = (1,2,3)--With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer).-Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard)-find the latter more helpful. Several other test cases (e.g. tcfail005) suggest-similarly. So: we should not do class defaulting with insolubles.--On the other hand, RuntimeRep-defaulting is different. Witness tcfail078:--  f :: Integer i => i-  f =               0--Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind-TYPE r0 -> Constraint and then complains that r0 is actually untouchable-(presumably, because it can't be sure if `Integer i` entails an equality).-If we default, we are told of a clash between (* -> Constraint) and Constraint.-The latter seems far better, suggesting we *should* do RuntimeRep-defaulting-even on insolubles.--But, evidently, not always. Witness UnliftedNewtypesInfinite:--  newtype Foo = FooC (# Int#, Foo #)--This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes).-If we default RuntimeRep-vars, we get--  Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted--which is just plain wrong.--Another situation in which we don't want to default involves concrete metavariables.--In equalities such as   alpha[conc] ~# rr[sk]  ,  alpha[conc] ~# RR beta[tau]-for a type family RR (all at kind RuntimeRep), we would prefer to report a-representation-polymorphism error rather than default alpha and get error:--  Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted`--which is very confusing. For this reason, we weed out the concrete-metavariables participating in such equalities in nonDefaultableTyVarsOfWC.-Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could-become soluble after defaulting beta (see also #21430).--Conclusion: we should do RuntimeRep-defaulting on insolubles only when the-user does not want to hear about RuntimeRep stuff -- that is, when--fprint-explicit-runtime-reps is not set.-However, we must still take care not to default concrete type variables-participating in an equality with a non-concrete type, as seen in the-last example above.--}---------------------simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()-simplifyAmbiguityCheck ty wc-  = do { traceTc "simplifyAmbiguityCheck {" $-         text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wc--       ; (final_wc, _) <- runTcS $ do { wc1 <- solveWanteds wc-                                      ; tryUnsatisfiableGivens wc1 }-             -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]-             -- Note: we do still use Unsatisfiable Givens to solve Wanteds,-             -- see Wrinkle [Ambiguity] under point (C) of-             -- Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors.--       ; discardResult (reportUnsolved final_wc)--       ; traceTc "End simplifyAmbiguityCheck }" empty }---------------------simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)-simplifyInteractive wanteds-  = traceTc "simplifyInteractive" empty >>-    simplifyTop wanteds---------------------simplifyDefault :: ThetaType    -- Wanted; has no type variables in it-                -> TcM Bool     -- Return if the constraint is soluble-simplifyDefault theta-  = do { traceTc "simplifyDefault" empty-       ; wanteds  <- newWanteds DefaultOrigin theta-       ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds))-       ; return (isEmptyWC unsolved) }---------------------{- Note [Pattern match warnings with insoluble Givens]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A pattern match on a GADT can introduce new type-level information, which needs-to be analysed in order to get the expected pattern match warnings.--For example:--> type IsBool :: Type -> Constraint-> type family IsBool a where->   IsBool Bool = ()->   IsBool b    = b ~ Bool->-> data T a where->   MkTInt  :: Int -> T Int->   MkTBool :: IsBool b => b -> T b->-> f :: T Int -> Int-> f (MkTInt i) = i--The pattern matching performed by `f` is complete: we can't ever call-`f (MkTBool b)`, as type-checking that application would require producing-evidence for `Int ~ Bool`, which can't be done.--The pattern match checker uses `tcCheckGivens` to accumulate all the Given-constraints, and relies on `tcCheckGivens` to return Nothing if the-Givens become insoluble.   `tcCheckGivens` in turn relies on `insolubleCt`-to identify these insoluble constraints.  So the precise definition of-`insolubleCt` has a big effect on pattern match overlap warnings.--To detect this situation, we check whether there are any insoluble Given-constraints. In the example above, the insoluble constraint was an-equality constraint, but it is also important to detect custom type errors:--> type NotInt :: Type -> Constraint-> type family NotInt a where->   NotInt Int = TypeError (Text "That's Int, silly.")->   NotInt _   = ()->-> data R a where->   MkT1 :: a -> R a->   MkT2 :: NotInt a => R a->-> foo :: R Int -> Int-> foo (MkT1 x) = x--To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble-because it is a custom type error.-Failing to do so proved quite inconvenient for users, as evidence by the-tickets #11503 #14141 #16377 #20180.-Test cases: T11503, T14141.--Examples of constraints that tcCheckGivens considers insoluble:-  - Int ~ Bool,-  - Coercible Float Word,-  - TypeError msg.--Non-examples:-  - constraints which we know aren't satisfied,-    e.g. Show (Int -> Int) when no such instance is in scope,-  - Eq (TypeError msg),-  - C (Int ~ Bool), with @class C (c :: Constraint)@.--}--tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet)--- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely--- contradictory.------ See Note [Pattern match warnings with insoluble Givens] above.-tcCheckGivens inerts given_ids = do-  (sat, new_inerts) <- runTcSInerts inerts $ do-    traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids)-    lcl_env <- TcS.getLclEnv-    let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)-    let given_cts = mkGivens given_loc (bagToList given_ids)-    -- See Note [Superclasses and satisfiability]-    solveSimpleGivens given_cts-    insols <- getInertInsols-    insols <- try_harder insols-    traceTcS "checkGivens }" (ppr insols)-    return (isEmptyBag insols)-  return $ if sat then Just new_inerts else Nothing-  where-    try_harder :: Cts -> TcS Cts-    -- Maybe we have to search up the superclass chain to find-    -- an unsatisfiable constraint.  Example: pmcheck/T3927b.-    -- At the moment we try just once-    try_harder insols-      | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable-      = return insols             -- Hurrah -- stop now.-      | otherwise-      = do { pending_given <- getPendingGivenScs-           ; new_given <- makeSuperClasses pending_given-           ; solveSimpleGivens new_given-           ; getInertInsols }--tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool--- ^ Return True if the Wanteds are soluble, False if not-tcCheckWanteds inerts wanteds = do-  cts <- newWanteds PatCheckOrigin wanteds-  (sat, _new_inerts) <- runTcSInerts inerts $ do-    traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds)-    -- See Note [Superclasses and satisfiability]-    wcs <- solveWanteds (mkSimpleWC cts)-    traceTcS "checkWanteds }" (ppr wcs)-    return (isSolvedWC wcs)-  return sat---- | Normalise a type as much as possible using the given constraints.--- See @Note [tcNormalise]@.-tcNormalise :: InertSet -> Type -> TcM Type-tcNormalise inerts ty-  = do { norm_loc <- getCtLocM PatCheckOrigin Nothing-       ; (res, _new_inerts) <- runTcSInerts inerts $-             do { traceTcS "tcNormalise {" (ppr inerts)-                ; ty' <- rewriteType norm_loc ty-                ; traceTcS "tcNormalise }" (ppr ty')-                ; pure ty' }-       ; return res }--{- Note [Superclasses and satisfiability]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Expand superclasses before starting, because (Int ~ Bool), has-(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool)-as a superclass, and it's the latter that is insoluble.  See-Note [The equality types story] in GHC.Builtin.Types.Prim.--If we fail to prove unsatisfiability we (arbitrarily) try just once to-find superclasses, using try_harder.  Reason: we might have a type-signature-   f :: F op (Implements push) => ..-where F is a type function.  This happened in #3972.--We could do more than once but we'd have to have /some/ limit: in the-the recursive case, we would go on forever in the common case where-the constraints /are/ satisfiable (#10592 comment:12!).--For straightforward situations without type functions the try_harder-step does nothing.--Note [tcNormalise]-~~~~~~~~~~~~~~~~~~-tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas-most invocations of the constraint solver are intended to simplify a set of-constraints or to decide if a particular set of constraints is satisfiable,-the purpose of tcNormalise is to take a type, plus some locally solved-constraints in the form of an InertSet, and normalise the type as much as-possible with respect to those constraints.--It does *not* reduce type or data family applications or look through newtypes.--Why is this useful? As one example, when coverage-checking an EmptyCase-expression, it's possible that the type of the scrutinee will only reduce-if some local equalities are solved for. See "Wrinkle: Local equalities"-in Note [Type normalisation] in "GHC.HsToCore.Pmc".--To accomplish its stated goal, tcNormalise first initialises the solver monad-with the given InertCans, then uses rewriteType to simplify the desired type-with respect to the Givens in the InertCans.--***********************************************************************************-*                                                                                 *-*                            Inference-*                                                                                 *-***********************************************************************************--Note [Inferring the type of a let-bound variable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f x = rhs--To infer f's type we do the following:- * Gather the constraints for the RHS with ambient level *one more than*-   the current one.  This is done by the call-        pushLevelAndCaptureConstraints (tcMonoBinds...)-   in GHC.Tc.Gen.Bind.tcPolyInfer-- * Call simplifyInfer to simplify the constraints and decide what to-   quantify over. We pass in the level used for the RHS constraints,-   here called rhs_tclvl.--This ensures that the implication constraint we generate, if any,-has a strictly-increased level compared to the ambient level outside-the let binding.--Note [Inferring principal types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't always infer principal types. For instance, the inferred type for--> f x = show [x]--is--> f :: Show a => a -> String--This is not the most general type if we allow flexible contexts.-Indeed, if we try to write the following--> g :: Show [a] => a -> String-> g x = f x--we get the error:--  * Could not deduce (Show a) arising from a use of `f'-    from the context: Show [a]--Though replacing f x in the right-hand side of g with the definition-of f x works, the call to f x does not. This is the hallmark of-unprincip{led,al} types.--Another example:--> class C a-> class D a where->   d :: a-> instance C a => D a where->   d = undefined-> h _ = d   -- argument is to avoid the monomorphism restriction--The inferred type for h is--> h :: C a => t -> a--even though--> h :: D a => t -> a--is more general.--The fix is easy: don't simplify constraints before inferring a type.-That is, have the inferred type quantify over all constraints that arise-in a definition's right-hand side, even if they are simplifiable.-Unfortunately, this would yield all manner of unwieldy types,-and so we won't do so.--}---- | How should we choose which constraints to quantify over?-data InferMode = ApplyMR          -- ^ Apply the monomorphism restriction,-                                  -- never quantifying over any constraints-               | EagerDefaulting  -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module",-                                  -- the :type +d case; this mode refuses-                                  -- to quantify over any defaultable constraint-               | NoRestrictions   -- ^ Quantify over any constraint that-                                  -- satisfies pickQuantifiablePreds--instance Outputable InferMode where-  ppr ApplyMR         = text "ApplyMR"-  ppr EagerDefaulting = text "EagerDefaulting"-  ppr NoRestrictions  = text "NoRestrictions"--simplifyInfer :: TcLevel               -- Used when generating the constraints-              -> InferMode-              -> [TcIdSigInst]         -- Any signatures (possibly partial)-              -> [(Name, TcTauType)]   -- Variables to be generalised,-                                       -- and their tau-types-              -> WantedConstraints-              -> TcM ([TcTyVar],    -- Quantify over these type variables-                      [EvVar],      -- ... and these constraints (fully zonked)-                      TcEvBinds,    -- ... binding these evidence variables-                      Bool)         -- True <=> the residual constraints are insoluble--simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds-  | isEmptyWC wanteds-   = do { -- When quantifying, we want to preserve any order of variables as they-          -- appear in partial signatures. cf. decideQuantifiedTyVars-          let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs-                                           , (_,Bndr tv _) <- sig_inst_skols sig ]-              psig_theta  = [ pred | sig <- partial_sigs-                                   , pred <- sig_inst_theta sig ]--       ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)--       ; skol_info <- mkSkolemInfo (InferSkol name_taus)-       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars-       ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)-       ; return (qtkvs, [], emptyTcEvBinds, False) }--  | otherwise-  = do { traceTc "simplifyInfer {"  $ vcat-             [ text "sigs =" <+> ppr sigs-             , text "binds =" <+> ppr name_taus-             , text "rhs_tclvl =" <+> ppr rhs_tclvl-             , text "infer_mode =" <+> ppr infer_mode-             , text "(unzonked) wanted =" <+> ppr wanteds-             ]--       ; let psig_theta = concatMap sig_inst_theta partial_sigs--       -- First do full-blown solving-       -- NB: we must gather up all the bindings from doing-       -- this solving; hence (runTcSWithEvBinds ev_binds_var).-       -- And note that since there are nested implications,-       -- calling solveWanteds will side-effect their evidence-       -- bindings, so we can't just revert to the input-       -- constraint.--       ; ev_binds_var <- TcM.newTcEvBinds-       ; psig_evs     <- newWanteds AnnOrigin psig_theta-       ; wanted_transformed-            <- setTcLevel rhs_tclvl $-               runTcSWithEvBinds ev_binds_var $-               solveWanteds (mkSimpleWC psig_evs `andWC` wanteds)-               -- psig_evs : see Note [Add signature contexts as wanteds]-               -- See Note [Inferring principal types]--       -- Find quant_pred_candidates, the predicates that-       -- we'll consider quantifying over-       -- NB1: wanted_transformed does not include anything provable from-       --      the psig_theta; it's just the extra bit-       -- NB2: We do not do any defaulting when inferring a type, this can lead-       --      to less polymorphic types, see Note [Default while Inferring]-       ; wanted_transformed <- TcM.liftZonkM $ TcM.zonkWC wanted_transformed-       ; let definite_error = insolubleWC wanted_transformed-                              -- See Note [Quantification with errors]-             quant_pred_candidates-               | definite_error = []-               | otherwise      = ctsPreds (approximateWC False wanted_transformed)--       -- Decide what type variables and constraints to quantify-       -- NB: quant_pred_candidates is already fully zonked-       -- NB: bound_theta are constraints we want to quantify over,-       --     including the psig_theta, which we always quantify over-       -- NB: bound_theta are fully zonked-       -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]-       --           in GHC.Tc.Utils.TcType-       ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification skol_info infer_mode rhs_tclvl-                                                     name_taus partial_sigs-                                                     quant_pred_candidates-             ; bound_theta_vars <- mapM TcM.newEvVar bound_theta--             ; let full_theta = map idType bound_theta_vars-             ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkPhiTy full_theta ty)-                                                    | (name, ty) <- name_taus ])-       }---       -- Now emit the residual constraint-       ; emitResidualConstraints rhs_tclvl ev_binds_var-                                 name_taus co_vars qtvs bound_theta_vars-                                 wanted_transformed--         -- All done!-       ; traceTc "} simplifyInfer/produced residual implication for quantification" $-         vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates-              , text "psig_theta ="     <+> ppr psig_theta-              , text "bound_theta ="    <+> pprCoreBinders bound_theta_vars-              , text "qtvs ="           <+> ppr qtvs-              , text "definite_error =" <+> ppr definite_error ]--       ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) }-         -- NB: bound_theta_vars must be fully zonked-  where-    partial_sigs = filter isPartialSig sigs-----------------------emitResidualConstraints :: TcLevel -> EvBindsVar-                        -> [(Name, TcTauType)]-                        -> CoVarSet -> [TcTyVar] -> [EvVar]-                        -> WantedConstraints -> TcM ()--- Emit the remaining constraints from the RHS.-emitResidualConstraints rhs_tclvl ev_binds_var-                        name_taus co_vars qtvs full_theta_vars wanteds-  | isEmptyWC wanteds-  = return ()--  | otherwise-  = do { wanted_simple <- TcM.liftZonkM $ TcM.zonkSimples (wc_simple wanteds)-       ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple-             is_mono ct-               | Just ct_ev_id <- wantedEvId_maybe ct-               = ct_ev_id `elemVarSet` co_vars-               | otherwise-               = False-             -- Reason for the partition:-             -- see Note [Emitting the residual implication in simplifyInfer]---- Already done by defaultTyVarsAndSimplify---      ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple)--        ; let inner_wanted = wanteds { wc_simple = inner_simple }-        ; implics <- if isEmptyWC inner_wanted-                     then return emptyBag-                     else do implic1 <- newImplication-                             return $ unitBag $-                                      implic1  { ic_tclvl     = rhs_tclvl-                                               , ic_skols     = qtvs-                                               , ic_given     = full_theta_vars-                                               , ic_wanted    = inner_wanted-                                               , ic_binds     = ev_binds_var-                                               , ic_given_eqs = MaybeGivenEqs-                                               , ic_info      = skol_info }--        ; emitConstraints (emptyWC { wc_simple = outer_simple-                                   , wc_impl   = implics }) }-  where-    full_theta = map idType full_theta_vars-    skol_info = InferSkol [ (name, mkPhiTy full_theta ty)-                          | (name, ty) <- name_taus ]-    -- We don't add the quantified variables here, because they are-    -- also bound in ic_skols and we want them to be tidied-    -- uniformly.-----------------------findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType--- Given a partial type signature f :: (C a, D a, _) => blah--- and the inferred constraints (X a, D a, Y a, C a)--- compute the difference, which is what will fill in the "_" underscore,--- In this case the diff is (X a, Y a).-findInferredDiff annotated_theta inferred_theta-  | null annotated_theta   -- Short cut the common case when the user didn't-  = return inferred_theta  -- write any constraints in the partial signature-  | otherwise-  = pushTcLevelM_ $-    do { lcl_env   <- TcM.getLclEnv-       ; given_ids <- mapM TcM.newEvVar annotated_theta-       ; wanteds   <- newWanteds AnnOrigin inferred_theta-       ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)-             given_cts = mkGivens given_loc given_ids--       ; (residual, _) <- runTcS $-                          do { _ <- solveSimpleGivens given_cts-                             ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }-         -- NB: There are no meta tyvars fromn this level annotated_theta-         -- because we have either promoted them or unified them-         -- See `Note [Quantification and partial signatures]` Wrinkle 2--       ; return (map (box_pred . ctPred) $-                 bagToList               $-                 wc_simple residual) }-  where-     box_pred :: PredType -> PredType-     box_pred pred = case classifyPredType pred of-                        EqPred rel ty1 ty2-                          | Just (cls,tys) <- boxEqPred rel ty1 ty2-                          -> mkClassPred cls tys-                          | otherwise-                          -> pprPanic "findInferredDiff" (ppr pred)-                        _other -> pred--{- Note [Emitting the residual implication in simplifyInfer]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f = e-where f's type is inferred to be something like (a, Proxy k (Int |> co))-and we have an as-yet-unsolved, or perhaps insoluble, constraint-   [W] co :: Type ~ k-We can't form types like (forall co. blah), so we can't generalise over-the coercion variable, and hence we can't generalise over things free in-its kind, in the case 'k'.  But we can still generalise over 'a'.  So-we'll generalise to-   f :: forall a. (a, Proxy k (Int |> co))-Now we do NOT want to form the residual implication constraint-   forall a. [W] co :: Type ~ k-because then co's eventual binding (which will be a value binding if we-use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose-type mentions 'co').  Instead, just as we don't generalise over 'co', we-should not bury its constraint inside the implication.  Instead, we must-put it outside.--That is the reason for the partitionBag in emitResidualConstraints,-which takes the CoVars free in the inferred type, and pulls their-constraints out.  (NB: this set of CoVars should be closed-over-kinds.)--All rather subtle; see #14584.--Note [Add signature contexts as wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#11016):-  f2 :: (?x :: Int) => _-  f2 = ?x--or this-  class C a b | a -> b-  g :: C p q => p -> q-  f3 :: C Int b => _-  f3 = g (3::Int)--We'll use plan InferGen because there are holes in the type.  But:- * For f2 we want to have the (?x :: Int) constraint floating around-   so that the functional dependencies kick in.  Otherwise the-   occurrence of ?x on the RHS produces constraint (?x :: alpha), and-   we won't unify alpha:=Int.-- * For f3 want the (C Int b) constraint from the partial signature-   to meet the (C Int beta) constraint we get from the call to g; again,-   fundeps--Solution: in simplifyInfer, we add the constraints from the signature-as extra Wanteds.--Why Wanteds?  Wouldn't it be neater to treat them as Givens?  Alas-that would mess up (GivenInv) in Note [TcLevel invariants].  Consider-    f :: (Eq a, _) => blah1-    f = ....g...-    g :: (Eq b, _) => blah2-    g = ...f...--Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with-TyVarTvs inside.  Ultimately a[tv] := b[tv], but only when we've solved-all those constraints.  And both have level 1, so we can't put them as-Givens when solving at level 1.--Best to treat them as Wanteds.--But see also #20076, which would be solved if they were Givens.---************************************************************************-*                                                                      *-                Quantification-*                                                                      *-************************************************************************--Note [Deciding quantification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the monomorphism restriction does not apply, then we quantify as follows:--* Step 1: decidePromotedTyVars.-  Take the global tyvars, and "grow" them using functional dependencies-     E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can-          happen because alpha is untouchable here) then do not quantify over-          beta, because alpha fixes beta, and beta is effectively free in-          the environment too; this logic extends to general fundeps, not-          just equalities--  We also account for the monomorphism restriction; if it applies,-  add the free vars of all the constraints.--  Result is mono_tvs; we will promote all of these to the outer levek,-  and certainly not quantify over them.--* Step 2: defaultTyVarsAndSimplify.-  Default any non-promoted tyvars (i.e ones that are definitely-  not going to become further constrained), and re-simplify the-  candidate constraints.--  Motivation for re-simplification (#7857): imagine we have a-  constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are-  not free in the envt, and instance forall (a::*) (b::*). (C a) => C-  (a -> b) The instance doesn't match while l1,l2 are polymorphic, but-  it will match when we default them to LiftedRep.--  This is all very tiresome.--  This step also promotes the mono_tvs from Step 1. See-  Note [Promote monomorphic tyvars]. In fact, the *only*-  use of the mono_tvs from Step 1 is to promote them here.-  This promotion effectively stops us from quantifying over them-  later, in Step 3. Because the actual variables to quantify-  over are determined in Step 3 (not in Step 1), it is OK for-  the mono_tvs to be missing some variables free in the-  environment. This is why removing the psig_qtvs is OK in-  decidePromotedTyVars. Test case for this scenario: T14479.--* Step 3: decideQuantifiedTyVars.-  Decide which variables to quantify over, as follows:--  - Take the free vars of the partial-type-signature types and constraints,-    and the tau-type (zonked_tau_tvs), and then "grow"-    them using all the constraints.  These are grown_tcvs.-    See Note [growThetaTyVars vs closeWrtFunDeps].--  - Use quantifyTyVars to quantify over the free variables of all the types-    involved, but only those in the grown_tcvs.--  Result is qtvs.--* Step 4: Filter the constraints using pickQuantifiablePreds and the-  qtvs. We have to zonk the constraints first, so they "see" the-  freshly created skolems.--Note [Unconditionally resimplify constraints when quantifying]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke-the solver to simplify the constraints before quantifying them. We do this for-two reasons, enumerated below. We could, in theory, detect when either of these-cases apply and simplify only then, but collecting this information is bothersome,-and simplifying redundantly causes no real harm. Note that this code path-happens only for definitions-  * without a type signature-  * when -XMonoLocalBinds does not apply-  * with unsolved constraints-and so the performance cost will be small.--1. Defaulting--Defaulting the variables handled by defaultTyVar may unlock instance simplifications.-Example (typecheck/should_compile/T20584b):--  with (t :: Double) (u :: String) = printf "..." t u--We know the types of t and u, but we do not know the return type of `with`. So, we-assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is-  printf :: PrintfType r => String -> r-The occurrence of printf is instantiated with a fresh var beta. We then get-  beta := Double -> String -> alpha-and-  [W] PrintfType (Double -> String -> alpha)--Module Text.Printf exports-  instance (PrintfArg a, PrintfType r) => PrintfType (a -> r)-and it looks like that instance should apply.--But I have elided some key details: (->) is polymorphic over multiplicity and-runtime representation. Here it is in full glory:-  [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho))-  instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type))--Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance-would have an explicit equality constraint to the left of =>, but that's not what we have.)-Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep.-Yet it's too late to simplify the quantified constraint, and thus GHC infers-  wait :: PrintfType (Double -> String -> t) => Double -> String -> t-which is silly. Simplifying again after defaulting solves this problem.--2. Interacting functional dependencies--Suppose we have--  class C a b | a -> b--and we are running simplifyInfer over--  forall[2] x. () => [W] C a beta1[1]-  forall[2] y. () => [W] C a beta2[1]--These are two implication constraints, both of which contain a-wanted for the class C. Neither constraint mentions the bound-skolem. We might imagine that these constraints could thus float-out of their implications and then interact, causing beta1 to unify-with beta2, but constraints do not currently float out of implications.--Unifying the beta1 and beta2 is important. Without doing so, then we might-infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the-ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as-required by the fundep interactions. This happens in the parsec library, and-in test case typecheck/should_compile/FloatFDs.--If we re-simplify, however, the two fundep constraints will interact, causing-a unification between beta1 and beta2, and all will be well. The key step-is that this simplification happens *after* the call to approximateWC in-simplifyInfer.---}--decideQuantification-  :: SkolemInfo-  -> InferMode-  -> TcLevel-  -> [(Name, TcTauType)]   -- Variables to be generalised-  -> [TcIdSigInst]         -- Partial type signatures (if any)-  -> [PredType]            -- Candidate theta; already zonked-  -> TcM ( [TcTyVar]       -- Quantify over these (skolems)-         , [PredType]      -- and this context (fully zonked)-         , CoVarSet)--- See Note [Deciding quantification]-decideQuantification skol_info infer_mode rhs_tclvl name_taus psigs candidates-  = do { -- Step 1: find the mono_tvs-       ; (candidates, co_vars, mono_tvs0)-             <- decidePromotedTyVars infer_mode name_taus psigs candidates--       -- Step 2: default any non-mono tyvars, and re-simplify-       -- This step may do some unification, but result candidates is zonked-       ; candidates <- defaultTyVarsAndSimplify rhs_tclvl candidates--       -- Step 3: decide which kind/type variables to quantify over-       ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates--       -- Step 4: choose which of the remaining candidate-       --         predicates to actually quantify over-       -- NB: decideQuantifiedTyVars turned some meta tyvars-       -- into quantified skolems, so we have to zonk again-       ; (candidates, psig_theta) <- TcM.liftZonkM $-          do { candidates <- TcM.zonkTcTypes candidates-             ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)-             ; return (candidates, psig_theta) }-       ; min_theta  <- pickQuantifiablePreds (mkVarSet qtvs) mono_tvs0 candidates--       -- Take account of partial type signatures-       -- See Note [Constraints in partial type signatures]-       ; let min_psig_theta = mkMinimalBySCs id psig_theta-       ; theta <- if-           | null psigs -> return min_theta                 -- Case (P3)-           | not (all has_extra_constraints_wildcard psigs) -- Case (P2)-             -> return min_psig_theta-           | otherwise                                      -- Case (P1)-             -> do { diff <- findInferredDiff min_psig_theta min_theta-                   ; return (min_psig_theta ++ diff) }--       ; traceTc "decideQuantification"-           (vcat [ text "infer_mode:" <+> ppr infer_mode-                 , text "candidates:" <+> ppr candidates-                 , text "psig_theta:" <+> ppr psig_theta-                 , text "co_vars:"    <+> ppr co_vars-                 , text "qtvs:"       <+> ppr qtvs-                 , text "theta:"      <+> ppr theta ])-       ; return (qtvs, theta, co_vars) }--  where-    has_extra_constraints_wildcard (TISI { sig_inst_wcx = Just {} }) = True-    has_extra_constraints_wildcard _                                 = False--{- Note [Constraints in partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have decided to quantify over min_theta, say (Eq a, C a, Ix a).-Then we distinguish three cases:--(P1) No partial type signatures: just quantify over min_theta--(P2) Partial type signatures with no extra_constraints wildcard:-      e.g.   f :: (Eq a, C a) => a -> _-     Quantify over psig_theta: the user has explicitly specified the-     entire context.--     That may mean we have an unsolved residual constraint (Ix a) arising-     from the RHS of the function. But so be it: the user said (Eq a, C a).--(P3) Partial type signature with an extra_constraints wildcard.-      e.g.   f :: (Eq a, C a, _) => a -> a-    Quantify over (psig_theta ++ diff)-      where diff = min_theta - psig_theta, using findInferredDiff.-    In our example, diff = Ix a--Some rationale and observations--* See Note [When the MR applies] in GHC.Tc.Gen.Bind.--* We always want to quantify over psig_theta (if present).  The user specified-  it!  And pickQuantifiableCandidates might have dropped some-  e.g. CallStack constraints.  c.f #14658-       equalities (a ~ Bool)--* In case (P3) we ask that /all/ the signatures have an extra-constraints-  wildcard.  It's a bit arbitrary; not clear what the "right" thing is.--* In (P2) we encounter #20076:-     f :: Eq [a] => a -> _-     f x = [x] == [x]-  From the RHS we get [W] Eq [a].  We simplify those Wanteds in simplifyInfer,-  to get (Eq a).  But then we quantify over the user-specified (Eq [a]), leaving-  a residual implication constraint (forall a. Eq [a] => [W] Eq a), which is-  insoluble.  Idea: in simplifyInfer we could put the /un-simplified/ constraints-  in the residual -- at least in the case like #20076 where the partial signature-  fully specifies the final constraint. Maybe: a battle for another day.--* It's helpful to use the same "find difference" algorithm, `findInferredDiff`,-  here as we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921)--  At least for single functions we would like to quantify f over precisely the-  same theta as <quant-theta>, so that we get to take the short-cut path in-  `GHC.Tc.Gen.Bind.mkExport`, and avoid calling `tcSubTypeSigma` for impedance-  matching. Why avoid?  Because it falls over for ambiguous types (#20921).--  We can get precisely the same theta by using the same algorithm,-  `findInferredDiff`.--* All of this goes wrong if we have (a) mutual recursion, (b) multiple-  partial type signatures, (c) with different constraints, and (d)-  ambiguous types.  Something like-    f :: forall a. Eq a => F a -> _-    f x = (undefined :: a) == g x undefined-    g :: forall b. Show b => F b -> _ -> b-    g x y = let _ = (f y, show x) in x-  But that's a battle for another day.--}--decidePromotedTyVars :: InferMode-                     -> [(Name,TcType)]-                     -> [TcIdSigInst]-                     -> [PredType]-                     -> TcM ([PredType], CoVarSet, TcTyVarSet)--- We are about to generalise over type variables at level N--- Each must be either---    (P) promoted---    (D) defaulted---    (Q) quantified--- This function finds (P), the type variables that we are going to promote:---   (a) Mentioned in a constraint we can't generalise (the MR)---   (b) Mentioned in the kind of a CoVar; we can't quantify over a CoVar,---       so we must not quantify over a type variable free in its kind---   (c) Connected by an equality or fundep to---          * a type variable at level < N, or---          * A tyvar subject to (a), (b) or (c)--- Having found all such level-N tyvars that we can't generalise,--- promote them, to eliminate them from further consideration.------ Also return CoVars that appear free in the final quantified types---   we can't quantify over these, and we must make sure they are in scope-decidePromotedTyVars infer_mode name_taus psigs candidates-  = do { tc_lvl <- TcM.getTcLevel-       ; (no_quant, maybe_quant) <- pick infer_mode candidates--       -- If possible, we quantify over partial-sig qtvs, so they are-       -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs-       ; (psig_qtvs, psig_theta, taus) <- TcM.liftZonkM $-          do { psig_qtvs <- zonkTcTyVarsToTcTyVars $ binderVars $-                            concatMap (map snd . sig_inst_skols) psigs-             ; psig_theta <- mapM TcM.zonkTcType $-                             concatMap sig_inst_theta psigs-             ; taus <- mapM (TcM.zonkTcType . snd) name_taus-             ; return (psig_qtvs, psig_theta, taus) }--       ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta--             -- (b) The co_var_tvs are tvs mentioned in the types of covars or-             -- coercion holes. We can't quantify over these covars, so we-             -- must include the variable in their types in the mono_tvs.-             -- E.g.  If we can't quantify over co :: k~Type, then we can't-             --       quantify over k either!  Hence closeOverKinds-             -- Recall that coVarsOfTypes also returns coercion holes-             co_vars = coVarsOfTypes (psig_tys ++ taus ++ candidates)-             co_var_tvs = closeOverKinds co_vars--             mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $-                         tyCoVarsOfTypes candidates-               -- We need to grab all the non-quantifiable tyvars in the-               -- types so that we can grow this set to find other-               -- non-quantifiable tyvars. This can happen with something like-               --    f x y = ...-               --      where z = x 3-               -- The body of z tries to unify the type of x (call it alpha[1])-               -- with (beta[2] -> gamma[2]). This unification fails because-               -- alpha is untouchable, leaving [W] alpha[1] ~ (beta[2] -> gamma[2]).-               -- We need to know not to quantify over beta or gamma, because they-               -- are in the equality constraint with alpha. Actual test case:-               -- typecheck/should_compile/tc213--             mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs--               -- mono_tvs1 is now the set of variables from an outer scope-               -- (that's mono_tvs0) and the set of covars, closed over kinds.-               -- Given this set of variables we know we will not quantify,-               -- we want to find any other variables that are determined by this-               -- set, by functional dependencies or equalities. We thus use-               -- closeWrtFunDeps to find all further variables determined by this root-               -- set. See Note [growThetaTyVars vs closeWrtFunDeps]--             non_ip_candidates = filterOut isIPLikePred candidates-               -- implicit params don't really determine a type variable-               -- (that is, we might have IP "c" Bool and IP "c" Int in different-               -- places within the same program), and-               -- skipping this causes implicit params to monomorphise too many-               -- variables; see Note [Inheriting implicit parameters] in GHC.Tc.Solver.-               -- Skipping causes typecheck/should_compile/tc219 to fail.--             mono_tvs2 = closeWrtFunDeps non_ip_candidates mono_tvs1-               -- mono_tvs2 now contains any variable determined by the "root-               -- set" of monomorphic tyvars in mono_tvs1.--             constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $-                               closeWrtFunDeps non_ip_candidates (tyCoVarsOfTypes no_quant)-                                `minusVarSet` mono_tvs2-             -- constrained_tvs: the tyvars that we are not going to-             -- quantify /solely/ because of the monomorphism restriction-             ---             -- (`minusVarSet` mono_tvs2): a type variable is only-             --   "constrained" (so that the MR bites) if it is not-             --   free in the environment (#13785) or is determined-             --   by some variable that is free in the env't--             mono_tvs = (mono_tvs2 `unionVarSet` constrained_tvs)-                        `delVarSetList` psig_qtvs-             -- (`delVarSetList` psig_qtvs): if the user has explicitly-             --   asked for quantification, then that request "wins"-             --   over the MR.-             ---             -- What if a psig variable is also free in the environment-             -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation-             -- in Step 2 of Note [Deciding quantification].--           -- Warn about the monomorphism restriction-       ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do-           let dia = TcRnMonomorphicBindings (map fst name_taus)-           diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia--       -- Promote the mono_tvs: see Note [Promote monomorphic tyvars]-       ; _ <- promoteTyVarSet mono_tvs--       ; traceTc "decidePromotedTyVars" $ vcat-           [ text "infer_mode =" <+> ppr infer_mode-           , text "psigs =" <+> ppr psigs-           , text "psig_qtvs =" <+> ppr psig_qtvs-           , text "mono_tvs0 =" <+> ppr mono_tvs0-           , text "no_quant =" <+> ppr no_quant-           , text "maybe_quant =" <+> ppr maybe_quant-           , text "mono_tvs =" <+> ppr mono_tvs-           , text "co_vars =" <+> ppr co_vars ]--       ; return (maybe_quant, co_vars, mono_tvs0) }-  where-    pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])-    -- Split the candidates into ones we definitely-    -- won't quantify, and ones that we might-    pick ApplyMR         cand = return (cand, [])-    pick NoRestrictions  cand = return ([], cand)-    pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings-                                   ; return (partition (is_int_ct os) cand) }--    -- is_int_ct returns True for a constraint we should /not/ quantify-    -- For EagerDefaulting, do not quantify over-    -- over any interactive class constraint-    is_int_ct ovl_strings pred-      = case classifyPredType pred of-           ClassPred cls _ -> isInteractiveClass ovl_strings cls-           _               -> False----------------------defaultTyVarsAndSimplify :: TcLevel-                         -> [PredType]          -- Assumed zonked-                         -> TcM [PredType]      -- Guaranteed zonked--- Default any tyvar free in the constraints;--- and re-simplify in case the defaulting allows further simplification-defaultTyVarsAndSimplify rhs_tclvl candidates-  = do {  -- Default any kind/levity vars-       ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}-                <- candidateQTyVarsOfTypes candidates-         -- NB1: decidePromotedTyVars has promoted any type variable fixed by the-         --      type envt, so they won't be chosen by candidateQTyVarsOfTypes-         -- NB2: Defaulting for variables free in tau_tys is done later, by quantifyTyVars-         --      Hence looking only at 'candidates'-         -- NB3: Any covars should already be handled by-         --      the logic in decidePromotedTyVars, which looks at-         --      the constraints generated--       ; poly_kinds  <- xoptM LangExt.PolyKinds-       ; let default_kv | poly_kinds = default_tv-                        | otherwise  = defaultTyVar DefaultKindVars-             default_tv = defaultTyVar (NonStandardDefaulting DefaultNonStandardTyVars)-       ; mapM_ default_kv (dVarSetElems cand_kvs)-       ; mapM_ default_tv (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))--       ; simplify_cand candidates-       }-  where-    -- See Note [Unconditionally resimplify constraints when quantifying]-    simplify_cand [] = return []  -- Fast path-    simplify_cand candidates-      = do { clone_wanteds <- newWanteds DefaultOrigin candidates-           ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $-                                           simplifyWantedsTcM clone_wanteds-              -- Discard evidence; simples is fully zonked--           ; let new_candidates = ctsPreds simples-           ; traceTc "Simplified after defaulting" $-                      vcat [ text "Before:" <+> ppr candidates-                           , text "After:"  <+> ppr new_candidates ]-           ; return new_candidates }---------------------decideQuantifiedTyVars-   :: SkolemInfo-   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs-   -> [TcIdSigInst]     -- Partial signatures-   -> [PredType]        -- Candidates, zonked-   -> TcM [TyVar]--- Fix what tyvars we are going to quantify over, and quantify them-decideQuantifiedTyVars skol_info name_taus psigs candidates-  = do {     -- Why psig_tys? We try to quantify over everything free in here-             -- See Note [Quantification and partial signatures]-             --     Wrinkles 2 and 3-       ; (psig_tv_tys, psig_theta, tau_tys) <- TcM.liftZonkM $-         do { psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs-                                                       , (_,Bndr tv _) <- sig_inst_skols sig ]-            ; psig_theta  <- mapM TcM.zonkTcType [ pred | sig <- psigs-                                                        , pred <- sig_inst_theta sig ]-            ; tau_tys     <- mapM (TcM.zonkTcType . snd) name_taus-            ; return (psig_tv_tys, psig_theta, tau_tys) }--       ; let -- Try to quantify over variables free in these types-             psig_tys = psig_tv_tys ++ psig_theta-             seed_tys = psig_tys ++ tau_tys--             -- Now "grow" those seeds to find ones reachable via 'candidates'-             -- See Note [growThetaTyVars vs closeWrtFunDeps]-             grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)--       -- Now we have to classify them into kind variables and type variables-       -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars-       ---       -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces-       -- them in that order, so that the final qtvs quantifies in the same-       -- order as the partial signatures do (#13524)-       ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $-                                                         psig_tys ++ candidates ++ tau_tys-       ; let pick     = (`dVarSetIntersectVarSet` grown_tcvs)-             dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }--       ; traceTc "decideQuantifiedTyVars" (vcat-           [ text "tau_tys =" <+> ppr tau_tys-           , text "candidates =" <+> ppr candidates-           , text "cand_kvs =" <+> ppr cand_kvs-           , text "cand_tvs =" <+> ppr cand_tvs-           , text "tau_tys =" <+> ppr tau_tys-           , text "seed_tys =" <+> ppr seed_tys-           , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys)-           , text "grown_tcvs =" <+> ppr grown_tcvs-           , text "dvs =" <+> ppr dvs_plus])--       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus }----------------------- | When inferring types, should we quantify over a given predicate?--- See Note [pickQuantifiablePreds]-pickQuantifiablePreds-  :: TyVarSet           -- Quantifying over these-  -> TcTyVarSet         -- mono_tvs0: variables mentioned a candidate-                        --   constraint that come from some outer level-  -> TcThetaType        -- Proposed constraints to quantify-  -> TcM TcThetaType    -- A subset that we can actually quantify--- This function decides whether a particular constraint should be--- quantified over, given the type variables that are being quantified-pickQuantifiablePreds qtvs mono_tvs0 theta-  = do { tc_lvl <- TcM.getTcLevel-       ; let is_nested = not (isTopTcLevel tc_lvl)-       ; return (mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]-                 mapMaybe (pick_me is_nested) theta) }-  where-    pick_me is_nested pred-      = let pred_tvs = tyCoVarsOfType pred-            mentions_qtvs = pred_tvs `intersectsVarSet` qtvs-        in case classifyPredType pred of--          ClassPred cls tys-            | Just {} <- isCallStackPred cls tys-              -- NEVER infer a CallStack constraint.  Otherwise we let-              -- the constraints bubble up to be solved from the outer-              -- context, or be defaulted when we reach the top-level.-              -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-            -> Nothing--            | isIPClass cls-            -> Just pred -- See Note [Inheriting implicit parameters]--            | not mentions_qtvs-            -> Nothing   -- Don't quantify over predicates that don't-                         -- mention any of the quantified type variables--            | is_nested-            -> Just pred--            -- From here on, we are thinking about top-level defns only--            | pred_tvs `subVarSet` (qtvs `unionVarSet` mono_tvs0)-              -- See Note [Do not quantify over constraints that determine a variable]-            -> Just pred--            | otherwise-            -> Nothing--          EqPred eq_rel ty1 ty2-            | mentions_qtvs-            , quantify_equality eq_rel ty1 ty2-            , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2-              -- boxEqPred: See Note [Lift equality constraints when quantifying]-            -> Just (mkClassPred cls tys)-            | otherwise-            -> Nothing--          IrredPred {} | mentions_qtvs -> Just pred-                       | otherwise     -> Nothing--          ForAllPred {} -> Nothing--    -- See Note [Quantifying over equality constraints]-    quantify_equality NomEq  ty1 ty2 = quant_fun ty1 || quant_fun ty2-    quantify_equality ReprEq _   _   = True--    quant_fun ty-      = case tcSplitTyConApp_maybe ty of-          Just (tc, tys) | isTypeFamilyTyCon tc-                         -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs-          _ -> False---------------------growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet--- See Note [growThetaTyVars vs closeWrtFunDeps]-growThetaTyVars theta tcvs-  | null theta = tcvs-  | otherwise  = transCloVarSet mk_next seed_tcvs-  where-    seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips-    (ips, non_ips) = partition isIPLikePred theta-                         -- See Note [Inheriting implicit parameters]--    mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones-    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips-    grow_one so_far pred tcvs-       | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs-       | otherwise                           = tcvs-       where-         pred_tcvs = tyCoVarsOfType pred---{- Note [Promote monomorphic tyvars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Promote any type variables that are free in the environment.  Eg-   f :: forall qtvs. bound_theta => zonked_tau-The free vars of f's type become free in the envt, and hence will show-up whenever 'f' is called.  They may currently at rhs_tclvl, but they-had better be unifiable at the outer_tclvl!  Example: envt mentions-alpha[1]-           tau_ty = beta[2] -> beta[2]-           constraints = alpha ~ [beta]-we don't quantify over beta (since it is fixed by envt)-so we must promote it!  The inferred type is just-  f :: beta -> beta--NB: promoteTyVarSet ignores coercion variables--Note [pickQuantifiablePreds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When pickQuantifiablePreds is called we have decided what type-variables to quantify over, `qtvs`. The only quesion is: which of the-unsolved candidate predicates should we quantify over?  Call them-`picked_theta`.--Note that will leave behind a residual implication-     forall qtvs. picked_theta => unsolved_constraints-For the members of unsolved_constraints that we select for picked_theta-it is easy to solve, by identity.  For the others we just hope that-we can solve them.--So which of the candidates should we pick to quantify over?  In some-situations we distinguish top-level from nested bindings.  The point-about nested binding is that- (a) the types may mention type variables free in the environment- (b) all of the call sites are statically visible, reducing the-     worries about "spooky action at a distance".--First, never pick a constraint that doesn't mention any of the quantified-variables `qtvs`.  Picking such a constraint essentially moves the solving of-the constraint from this function definition to call sites.  But because the-constraint mentions no quantified variables, call sites have no advantage-over the definition site. Well, not quite: there could be new constraints-brought into scope by a pattern-match against a constrained (e.g. GADT)-constructor.  Example--      data T a where { T1 :: T1 Bool; ... }--      f :: forall a. a -> T a -> blah-      f x t = let g y = x&&y    -- This needs a~Bool-            in case t of-                  T1 -> g True-                  ....--At g's call site we have `a~Bool`, so we /could/ infer-     g :: forall . (a~Bool) => Bool -> Bool  -- qtvs = {}--This is all very contrived, and probably just postponse type errors to-the call site.  If that's what you want, write a type signature.--Actually, implicit parameters is an exception to the "no quantified vars"-rule (see Note [Inheriting implicit parameters]) so we can't actually-simply test this case first.--Now we consider the different sorts of constraints:--* For ClassPred constraints:--  * Never pick a CallStack constraint.-    See Note [Overview of implicit CallStacks]--  * Always pick an implicit-parameter constraint.-    Note [Inheriting implicit parameters]--  * For /top-level/ class constraints see-    Note [Do not quantify over constraints that determine a variable]--* For EqPred constraints see Note [Quantifying over equality constraints]--* For IrredPred constraints, we allow anything that mentions the quantified-  type variables.--* A ForAllPred should not appear: the candidates come from approximateWC.--Notice that we do /not/ consult -XFlexibleContexts here.  For example,-we allow `pickQuantifiablePreds` to quantify over a constraint like-`Num [a]`; then if we don't have `-XFlexibleContexts` we'll get an-error from `checkValidType` but (critically) it includes the helpful-suggestion of adding `-XFlexibleContexts`.  See #10608, #10351.--Note [Lift equality constraints when quantifying]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We can't quantify over a constraint (t1 ~# t2) because that isn't a-predicate type; see Note [Types for coercions, predicates, and evidence]-in GHC.Core.TyCo.Rep.--So we have to 'lift' it to (t1 ~ t2).  Similarly (~R#) must be lifted-to Coercible.--This tiresome lifting is the reason that pick_me (in-pickQuantifiablePreds) returns a Maybe rather than a Bool.--Note [Inheriting implicit parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:--        f x = (x::Int) + ?y--where f is *not* a top-level binding.-From the RHS of f we'll get the constraint (?y::Int).-There are two types we might infer for f:--        f :: Int -> Int--(so we get ?y from the context of f's definition), or--        f :: (?y::Int) => Int -> Int--At first you might think the first was better, because then-?y behaves like a free variable of the definition, rather than-having to be passed at each call site.  But of course, the WHOLE-IDEA is that ?y should be passed at each call site (that's what-dynamic binding means) so we'd better infer the second.--BOTTOM LINE: when *inferring types* you must quantify over implicit-parameters, *even if* they don't mention the bound type variables.-Reason: because implicit parameters, uniquely, have local instance-declarations. See pickQuantifiablePreds.--Note [Quantifying over equality constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Should we quantify over an equality constraint (s ~ t)-in pickQuantifiablePreds?--* It is always /sound/ to quantify over a constraint -- those-  quantified constraints will need to be proved at each call site.--* We definitely don't want to quantify over (Maybe a ~ Bool), to get-     f :: forall a. (Maybe a ~ Bool) => blah-  That simply postpones a type error from the function definition site to-  its call site.  Fortunately we have already filtered out insoluble-  constraints: see `definite_error` in `simplifyInfer`.--* What about (a ~ T alpha b), where we are about to quantify alpha, `a` and-  `b` are in-scope skolems, and `T` is a data type.  It's pretty unlikely-  that this will be soluble at a call site, so we don't quantify over it.--* What about `(F beta ~ Int)` where we are going to quantify `beta`?-  Should we quantify over the (F beta ~ Int), to get-     f :: forall b. (F b ~ Int) => blah-  Aha!  Perhaps yes, because at the call site we will instantiate `b`, and-  perhaps we have `instance F Bool = Int`. So we *do* quantify over a-  type-family equality where the arguments mention the quantified variables.--This is all a bit ad-hoc.--Note [Do not quantify over constraints that determine a variable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (typecheck/should_compile/tc231), where we're trying to infer-the type of a top-level declaration. We have-  class Zork s a b | a -> b-and the candidate constraint at the end of simplifyInfer is-  [W] Zork alpha[1] (Z [Char]) beta[1]-We definitely want to quantify over `alpha` (which is mentioned in the-tau-type).--But we do *not* want to quantify over `beta`: it is determined by the-functional dependency on Zork: note that the second argument to Zork-in the Wanted is a variable-free `Z [Char]`.  Quantifying over it-would be "Henry Ford polymorphism".  (Presumably we don't have an-instance in scope that tells us what `beta` actually is.)  Instead-we promote `beta[1]` to `beta[0]`, in `decidePromotedTyVars`.--The question here: do we want to quantify over the constraint, to-give the type-   forall a. Zork a (Z [Char]) beta[0] => blah-Definitely not.  Since we're not quantifying over beta, it has been-promoted; and then will be zapped to Any in the final zonk.  So we end-up with a (perhaps exported) type involving-  forall a. Zork a (Z [Char]) Any => blah-No no no:--  Key principle: we never want to show the programmer-                 a type with `Any` in it.--What we really want (to catch the Zork example) is this:--   Quantify over the constraint only if all its free variables are-   (a) quantified, or-   (b) appears in the type of something in the environment (mono_tvs0).--To understand (b) consider--  class C a b where { op :: a -> b -> () }--  mr = 3                      -- mr :: alpha-  f1 x = op x mr              -- f1 :: forall b. b -> (), plus [W] C b alpha-  intify = mr + (4 :: Int)--In `f1` should we quantify over that `(C b alpha)`?  Answer: since `alpha`-is free in the type envt, yes we should.  After all, if we'd typechecked-`intify` first, we'd have set `alpha := Int`, and /then/ we'd certainly-quantify.  The delicate Zork situation applies when beta is completely-unconstrained (not free in the environment) -- except by the fundep.--Another way to put it: let's say `alpha` is in `mono_tvs0`. It must be that-some variable `x` has `alpha` free in its type. If we are at top-level (and we-are, because nested decls don't go through this path all), then `x` must also-be at top-level. And, by induction, `x` will not have Any in its type when all-is said and done. The induction is well-founded because, if `x` is mutually-recursive with the definition at hand, then their constraints get processed-together (or `x` has a type signature, in which case the type doesn't have-`Any`). So the key thing is that we must not introduce a new top-level-unconstrained variable here.--However this regrettably-subtle reasoning is needed only for /top-level/-declarations.  For /nested/ decls we can see all the calls, so we'll-instantiate that quantifed `Zork a (Z [Char]) beta` constraint at call sites,-and either solve it or not (probably not).  We won't be left with a-still-callable function with Any in its type.  So for nested definitions we-don't make this tricky test.--Historical note: we had a different, and more complicated test-before, but it was utterly wrong: #23199.--Note [Quantification and partial signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When choosing type variables to quantify, the basic plan is to-quantify over all type variables that are- * free in the tau_tvs, and- * not forced to be monomorphic (mono_tvs),-   for example by being free in the environment.--However, in the case of a partial type signature, we are doing inference-*in the presence of a type signature*. For example:-   f :: _ -> a-   f x = ...-or-   g :: (Eq _a) => _b -> _b-In both cases we use plan InferGen, and hence call simplifyInfer.  But-those 'a' variables are skolems (actually TyVarTvs), and we should be-sure to quantify over them.  This leads to several wrinkles:--* Wrinkle 1.  In the case of a type error-     f :: _ -> Maybe a-     f x = True && x-  The inferred type of 'f' is f :: Bool -> Bool, but there's a-  left-over error of form (Maybe a ~ Bool).  The error-reporting-  machine expects to find a binding site for the skolem 'a', so we-  add it to the quantified tyvars.--* Wrinkle 2.  Consider the partial type signature-     f :: (Eq _) => Int -> Int-     f x = x-  In normal cases that makes sense; e.g.-     g :: Eq _a => _a -> _a-     g x = x-  where the signature makes the type less general than it could-  be. But for 'f' we must therefore quantify over the user-annotated-  constraints, to get-     f :: forall a. Eq a => Int -> Int-  (thereby correctly triggering an ambiguity error later).  If we don't-  we'll end up with a strange open type-     f :: Eq alpha => Int -> Int-  which isn't ambiguous but is still very wrong.--  Bottom line: Try to quantify over any variable free in psig_theta,-  just like the tau-part of the type.--* Wrinkle 3 (#13482). Also consider-    f :: forall a. _ => Int -> Int-    f x = if (undefined :: a) == undefined then x else 0-  Here we get an (Eq a) constraint, but it's not mentioned in the-  psig_theta nor the type of 'f'.  But we still want to quantify-  over 'a' even if the monomorphism restriction is on.--* Wrinkle 4 (#14479)-    foo :: Num a => a -> a-    foo xxx = g xxx-      where-        g :: forall b. Num b => _ -> b-        g y = xxx + y--  In the signature for 'g', we cannot quantify over 'b' because it turns out to-  get unified with 'a', which is free in g's environment.  So we carefully-  refrain from bogusly quantifying, in GHC.Tc.Solver.decidePromotedTyVars.  We-  report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers.--Note [growThetaTyVars vs closeWrtFunDeps]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with-the same type and similar behavior. This Note outlines the differences-and why we use one or the other.--Both functions take a list of constraints. We will call these the-*candidates*.--closeWrtFunDeps takes a set of "determined" type variables and finds the-closure of that set with respect to the functional dependencies-within the class constraints in the set of candidates. So, if we-have--  class C a b | a -> b-  class D a b   -- no fundep-  candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)}--then closeWrtFunDeps {a} will return the set {a,b,c}.-This is because, if `a` is determined, then `b` and `c` are, too,-by functional dependency. closeWrtFunDeps called with any seed set not including-`a` will just return its argument, as only `a` determines any other-type variable (in this example).--growThetaTyVars operates similarly, but it behaves as if every-constraint has a functional dependency among all its arguments.-So, continuing our example, growThetaTyVars {a} will return-{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of-variables to include all variables that are mentioned in the same-constraint (transitively).--We use closeWrtFunDeps in places where we need to know which variables are-*always* determined by some seed set. This includes-  * when determining the mono-tyvars in decidePromotedTyVars. If `a`-    is going to be monomorphic, we need b and c to be also: they-    are determined by the choice for `a`.-  * when checking instance coverage, in-    GHC.Tc.Instance.FunDeps.checkInstCoverage--On the other hand, we use growThetaTyVars where we need to know-which variables *might* be determined by some seed set. This includes-  * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers-    and decideQuantifiedTyVars-How can `a` determine (say) `d` in the example above without a fundep?-Suppose we have-  instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c)-Now, if `a` turns out to be a list, it really does determine b and c.-The danger in overdoing quantification is the creation of an ambiguous-type signature, but this is conveniently caught in the validity checker.--Note [Quantification with errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we find that the RHS of the definition has some absolutely-insoluble-constraints (including especially "variable not in scope"), we--* Abandon all attempts to find a context to quantify over,-  and instead make the function fully-polymorphic in whatever-  type we have found--* Return a flag from simplifyInfer, indicating that we found an-  insoluble constraint.  This flag is used to suppress the ambiguity-  check for the inferred type, which may well be bogus, and which-  tends to obscure the real error.  This fix feels a bit clunky,-  but I failed to come up with anything better.--Reasons:-    - Avoid downstream errors-    - Do not perform an ambiguity test on a bogus type, which might well-      fail spuriously, thereby obfuscating the original insoluble error.-      #14000 is an example--I tried an alternative approach: simply failM, after emitting the-residual implication constraint; the exception will be caught in-GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type-(forall a. a).  But that didn't work with -fdefer-type-errors, because-the recovery from failM emits no code at all, so there is no function-to run!   But -fdefer-type-errors aspires to produce a runnable program.--Note [Default while Inferring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Our current plan is that defaulting only happens at simplifyTop and-not simplifyInfer.  This may lead to some insoluble deferred constraints.-Example:--instance D g => C g Int b--constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha-type inferred       = gamma -> gamma--Now, if we try to default (alpha := Int) we will be able to refine the implication to-  (forall b. 0 => C gamma Int b)-which can then be simplified further to-  (forall b. 0 => D gamma)-Finally, we /can/ approximate this implication with (D gamma) and infer the quantified-type:  forall g. D g => g -> g--Instead what will currently happen is that we will get a quantified type-(forall g. g -> g) and an implication:-       forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha--Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an-unsolvable implication:-       forall g. 0 => (forall b. 0 => D g)--The concrete example would be:-       h :: C g a s => g -> a -> ST s a-       f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)--But it is quite tedious to do defaulting and resolve the implication constraints, and-we have not observed code breaking because of the lack of defaulting in inference, so-we don't do it for now.----Note [Minimize by Superclasses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we quantify over a constraint, in simplifyInfer we need to-quantify over a constraint that is minimal in some sense: For-instance, if the final wanted constraint is (Eq alpha, Ord alpha),-we'd like to quantify over Ord alpha, because we can just get Eq alpha-from superclass selection from Ord alpha. This minimization is what-mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint-to check the original wanted.---Note [Avoid unnecessary constraint simplification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    -------- NB NB NB (Jun 12) --------------    This note not longer applies; see the notes with #4361.-    But I'm leaving it in here so we remember the issue.)-    -----------------------------------------When inferring the type of a let-binding, with simplifyInfer,-try to avoid unnecessarily simplifying class constraints.-Doing so aids sharing, but it also helps with delicate-situations like--   instance C t => C [t] where ..--   f :: C [t] => ....-   f x = let g y = ...(constraint C [t])...-         in ...-When inferring a type for 'g', we don't want to apply the-instance decl, because then we can't satisfy (C t).  So we-just notice that g isn't quantified over 't' and partition-the constraints before simplifying.--This only half-works, but then let-generalisation only half-works.--*********************************************************************************-*                                                                                 *-*                                 Main Simplifier                                 *-*                                                                                 *-***********************************************************************************---}--simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints--- Solve the specified Wanted constraints--- Discard the evidence binds--- Postcondition: fully zonked-simplifyWantedsTcM wanted-  = do { traceTc "simplifyWantedsTcM {" (ppr wanted)-       ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted))-       ; result <- TcM.liftZonkM $ TcM.zonkWC result-       ; traceTc "simplifyWantedsTcM }" (ppr result)-       ; return result }--solveWanteds :: WantedConstraints -> TcS WantedConstraints-solveWanteds wc@(WC { wc_errors = errs })-  | isEmptyWC wc  -- Fast path-  = return wc-  | otherwise-  = do { cur_lvl <- TcS.getTcLevel-       ; traceTcS "solveWanteds {" $-         vcat [ text "Level =" <+> ppr cur_lvl-              , ppr wc ]--       ; dflags <- getDynFlags-       ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc--       ; errs' <- simplifyDelayedErrors errs-       ; let final_wc = solved_wc { wc_errors = errs' }--       ; ev_binds_var <- getTcEvBindsVar-       ; bb <- TcS.getTcEvBindsMap ev_binds_var-       ; traceTcS "solveWanteds }" $-                 vcat [ text "final wc =" <+> ppr final_wc-                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]--       ; return final_wc }--simplify_loop :: Int -> IntWithInf -> Bool-              -> WantedConstraints -> TcS WantedConstraints--- Do a round of solving, and call maybe_simplify_again to iterate--- The 'definitely_redo_implications' flags is False if the only reason we--- are iterating is that we have added some new Wanted superclasses--- hoping for fundeps to help us; see Note [Superclass iteration]------ Does not affect wc_holes at all; reason: wc_holes never affects anything--- else, so we do them once, at the end in solveWanteds-simplify_loop n limit definitely_redo_implications-              wc@(WC { wc_simple = simples, wc_impl = implics })-  = do { csTraceTcS $-         text "simplify_loop iteration=" <> int n-         <+> (parens $ hsep [ text "definitely_redo =" <+> ppr definitely_redo_implications <> comma-                            , int (lengthBag simples) <+> text "simples to solve" ])-       ; traceTcS "simplify_loop: wc =" (ppr wc)--       ; (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.InertSet--       ; wc2 <- if not definitely_redo_implications  -- See Note [Superclass iteration]-                   && unifs1 == 0                    -- for this conditional-                   && isEmptyBag (wc_impl wc1)-                then return (wc { wc_simple = wc_simple wc1 })  -- Short cut-                else do { implics2 <- solveNestedImplications $-                                      implics `unionBags` (wc_impl wc1)-                        ; return (wc { wc_simple = wc_simple wc1-                                     , wc_impl = implics2 }) }--       ; unif_happened <- resetUnificationFlag-       ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened-         -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad-       ; maybe_simplify_again (n+1) limit unif_happened wc2 }--maybe_simplify_again :: Int -> IntWithInf -> Bool-                     -> WantedConstraints -> TcS WantedConstraints-maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples })-  | n `intGtLimit` limit-  = do { -- Add an error (not a warning) if we blow the limit,-         -- Typically if we blow the limit we are going to report some other error-         -- (an unsolved constraint), and we don't want that error to suppress-         -- the iteration limit warning!-         addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc-       ; return wc }--  | unif_happened-  = simplify_loop n limit True wc--  | superClassesMightHelp wc-  = -- We still have unsolved goals, and apparently no way to solve them,-    -- so try expanding superclasses at this level, both Given and Wanted-    do { pending_given <- getPendingGivenScs-       ; let (pending_wanted, simples1) = getPendingWantedScs simples-       ; if null pending_given && null pending_wanted-           then return wc  -- After all, superclasses did not help-           else-    do { new_given  <- makeSuperClasses pending_given-       ; new_wanted <- makeSuperClasses pending_wanted-       ; solveSimpleGivens new_given -- Add the new Givens to the inert set-       ; traceTcS "maybe_simplify_again" (vcat [ text "pending_given" <+> ppr pending_given-                                               , text "new_given" <+> ppr new_given-                                               , text "pending_wanted" <+> ppr pending_wanted-                                               , text "new_wanted" <+> ppr new_wanted ])-       ; simplify_loop n limit (not (null pending_given)) $-         wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }-         -- (not (null pending_given)): see Note [Superclass iteration]--  | otherwise-  = return wc--{- Note [Superclass iteration]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this implication constraint-    forall a.-       [W] d: C Int beta-       forall b. blah-where-  class D a b | a -> b-  class D a b => C a b-We will expand d's superclasses, giving [W] D Int beta, in the hope of geting-fundeps to unify beta.  Doing so is usually fruitless (no useful fundeps),-and if so it seems a pity to waste time iterating the implications (forall b. blah)-(If we add new Given superclasses it's a different matter: it's really worth looking-at the implications.)--Hence the definitely_redo_implications flag to simplify_loop.  It's usually-True, but False in the case where the only reason to iterate is new Wanted-superclasses.  In that case we check whether the new Wanteds actually led to-any new unifications, and iterate the implications only if so.--}--{- Note [Expanding Recursive Superclasses and ExpansionFuel]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the class declaration (T21909)--    class C [a] => C a where-       foo :: a -> Int--and suppose during type inference we obtain an implication constraint:--    forall a. C a => C [[a]]--To solve this implication constraint, we first expand one layer of the superclass-of Given constraints, but not for Wanted constraints.-(See Note [Eagerly expand given superclasses] and Note [Why adding superclasses can help]-in GHC.Tc.Solver.Dict.) We thus get:--    [G] g1 :: C a-    [G] g2 :: C [a]    -- new superclass layer from g1-    [W] w1 :: C [[a]]--Now, we cannot solve `w1` directly from `g1` or `g2` as we may not have-any instances for C. So we expand a layer of superclasses of each Wanteds and Givens-that we haven't expanded yet.-This is done in `maybe_simplify_again`. And we get:--    [G] g1 :: C a-    [G] g2 :: C [a]-    [G] g3 :: C [[a]]    -- new superclass layer from g2, can solve w1-    [W] w1 :: C [[a]]-    [W] w2 :: C [[[a]]]  -- new superclass layer from w1, not solvable--Now, although we can solve `w1` using `g3` (obtained from expanding `g2`),-we have a new wanted constraint `w2` (obtained from expanding `w1`) that cannot be solved.-We thus make another go at solving in `maybe_simplify_again` by expanding more-layers of superclasses. This looping is futile as Givens will never be able to catch up with Wanteds.--Side Note: In principle we don't actually need to /solve/ `w2`, as it is a superclass of `w1`-but we only expand it to expose any functional dependencies (see Note [The superclass story])-But `w2` is a wanted constraint, so we will try to solve it like any other,-even though ultimately we will discard its evidence.--Solution: Simply bound the maximum number of layers of expansion for-Givens and Wanteds, with ExpansionFuel.  Give the Givens more fuel-(say 3 layers) than the Wanteds (say 1 layer). Now the Givens will-win.  The Wanteds don't need much fuel: we are only expanding at all-to expose functional dependencies, and wantedFuel=1 means we will-expand a full recursive layer.  If the superclass hierarchy is-non-recursive (the normal case) one layer is therefore full expansion.--The default value for wantedFuel = Constants.max_WANTEDS_FUEL = 1.-The default value for givenFuel  = Constants.max_GIVENS_FUEL = 3.-Both are configurable via the `-fgivens-fuel` and `-fwanteds-fuel`-compiler flags.--There are two preconditions for the default fuel values:-   (1) default givenFuel >= default wantedsFuel-   (2) default givenFuel < solverIterations--Precondition (1) ensures that we expand givens at least as many times as we expand wanted constraints-preferably givenFuel > wantedsFuel to avoid issues like T21909 while-the precondition (2) ensures that we do not reach the solver iteration limit and fail with a-more meaningful error message (see T19627)--This also applies for quantified constraints; see `-fqcs-fuel` compiler flag and `QCI.qci_pend_sc` field.--}---solveNestedImplications :: Bag Implication-                        -> TcS (Bag Implication)--- Precondition: the TcS inerts may contain unsolved simples which have--- to be converted to givens before we go inside a nested implication.-solveNestedImplications implics-  | isEmptyBag implics-  = return (emptyBag)-  | otherwise-  = do { traceTcS "solveNestedImplications starting {" empty-       ; unsolved_implics <- mapBagM solveImplication implics--       -- ... and we are back in the original TcS inerts-       -- Notice that the original includes the _insoluble_simples so it was safe to ignore-       -- them in the beginning of this function.-       ; traceTcS "solveNestedImplications end }" $-                  vcat [ text "unsolved_implics =" <+> ppr unsolved_implics ]--       ; return (catBagMaybes unsolved_implics) }--solveImplication :: Implication    -- Wanted-                 -> TcS (Maybe Implication) -- Simplified implication (empty or singleton)--- Precondition: The TcS monad contains an empty worklist and given-only inerts--- which after trying to solve this implication we must restore to their original value-solveImplication imp@(Implic { ic_tclvl  = tclvl-                             , ic_binds  = ev_binds_var-                             , ic_given  = given_ids-                             , ic_wanted = wanteds-                             , ic_info   = info-                             , ic_status = status })-  | isSolvedStatus status-  = return (Just imp)  -- Do nothing--  | otherwise  -- Even for IC_Insoluble it is worth doing more work-               -- The insoluble stuff might be in one sub-implication-               -- and other unsolved goals in another; and we want to-               -- solve the latter as much as possible-  = do { inerts <- getInertSet-       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)--       -- commented out; see `where` clause below-       -- ; when debugIsOn check_tc_level--         -- Solve the nested constraints-       ; (has_given_eqs, given_insols, residual_wanted)-            <- nestImplicTcS ev_binds_var tclvl $-               do { let loc    = mkGivenLoc tclvl info (ic_env imp)-                        givens = mkGivens loc given_ids-                  ; solveSimpleGivens givens--                  ; residual_wanted <- solveWanteds wanteds--                  ; (has_eqs, given_insols) <- getHasGivenEqs tclvl-                        -- Call getHasGivenEqs /after/ solveWanteds, because-                        -- solveWanteds can augment the givens, via expandSuperClasses,-                        -- to reveal given superclass equalities--                  ; return (has_eqs, given_insols, residual_wanted) }--       ; traceTcS "solveImplication 2"-           (ppr given_insols $$ ppr residual_wanted)-       ; let final_wanted = residual_wanted `addInsols` given_insols-             -- Don't lose track of the insoluble givens,-             -- which signal unreachable code; put them in ic_wanted--       ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs-                                                 , ic_wanted = final_wanted })--       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var-       ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var-       ; traceTcS "solveImplication end }" $ vcat-             [ text "has_given_eqs =" <+> ppr has_given_eqs-             , text "res_implic =" <+> ppr res_implic-             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)-             , text "implication tvcs =" <+> ppr tcvs ]--       ; return res_implic }--    -- TcLevels must be strictly increasing (see (ImplicInv) in-    -- Note [TcLevel invariants] in GHC.Tc.Utils.TcType),-    -- and in fact I think they should always increase one level at a time.--    -- Though sensible, this check causes lots of testsuite failures. It is-    -- remaining commented out for now.-    {--    check_tc_level = do { cur_lvl <- TcS.getTcLevel-                        ; massertPpr (tclvl == pushTcLevel cur_lvl)-                                     (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) }-    -}-------------------------setImplicationStatus :: Implication -> TcS (Maybe Implication)--- Finalise the implication returned from solveImplication,--- setting the ic_status field--- Precondition: the ic_status field is not already IC_Solved--- Return Nothing if we can discard the implication altogether-setImplicationStatus implic@(Implic { ic_status     = old_status-                                    , ic_info       = info-                                    , ic_wanted     = wc-                                    , ic_given      = givens })- | assertPpr (not (isSolvedStatus old_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)--      ; implic <- neededEvVars implic--      ; let new_status | insolubleWC pruned_wc = IC_Insoluble-                       | otherwise             = IC_Unsolved-            new_implic = implic { ic_status = new_status-                                , ic_wanted = pruned_wc }--      ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic)--      ; return $ Just new_implic }-- | otherwise  -- Everything is solved-              -- Set status to IC_Solved,-              -- and compute the dead givens and outer needs-              -- See Note [Tracking redundant constraints]- = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic)--      ; implic@(Implic { ic_need_inner = need_inner-                       , ic_need_outer = need_outer }) <- neededEvVars implic--      ; bad_telescope <- checkBadTelescope implic--      ; let warn_givens = findUnnecessaryGivens info need_inner givens--            discard_entire_implication  -- Can we discard the entire implication?-              =  null warn_givens           -- No warning from this implication-              && not bad_telescope-              && isEmptyWC pruned_wc        -- No live children-              && isEmptyVarSet need_outer   -- No needed vars to pass up to parent--            final_status-              | bad_telescope = IC_BadTelescope-              | otherwise     = IC_Solved { ics_dead = warn_givens }-            final_implic = implic { ic_status = final_status-                                  , ic_wanted = pruned_wc }--      ; traceTcS "setImplicationStatus(all-solved) }" $-        vcat [ text "discard:" <+> ppr discard_entire_implication-             , text "new_implic:" <+> ppr final_implic ]--      ; return $ if discard_entire_implication-                 then Nothing-                 else Just final_implic }- where-   WC { wc_simple = simples, wc_impl = implics, wc_errors = errs } = wc--   pruned_implics = filterBag keep_me implics-   pruned_wc = WC { wc_simple = simples-                  , wc_impl   = pruned_implics-                  , wc_errors = errs }   -- do not prune holes; these should be reported--   keep_me :: Implication -> Bool-   keep_me ic-     | IC_Solved { ics_dead = dead_givens } <- ic_status ic-                          -- Fully solved-     , null dead_givens   -- No redundant givens to report-     , isEmptyBag (wc_impl (ic_wanted ic))-           -- And no children that might have things to report-     = False       -- Tnen we don't need to keep it-     | otherwise-     = True        -- Otherwise, keep it--findUnnecessaryGivens :: SkolemInfoAnon -> VarSet -> [EvVar] -> [EvVar]-findUnnecessaryGivens info need_inner givens-  | not (warnRedundantGivens info)   -- Don't report redundant constraints at all-  = []--  | not (null unused_givens)         -- Some givens are literally unused-  = unused_givens--  | otherwise                       -- All givens are used, but some might-  = redundant_givens                -- still be redundant e.g. (Eq a, Ord a)--  where-    in_instance_decl = case info of { InstSkol {} -> True; _ -> False }-                       -- See Note [Redundant constraints in instance decls]--    unused_givens = filterOut is_used givens--    is_used given =  is_type_error given-                  || given `elemVarSet` need_inner-                  || (in_instance_decl && is_improving (idType given))--    minimal_givens = mkMinimalBySCs evVarPred givens-    is_minimal = (`elemVarSet` mkVarSet minimal_givens)-    redundant_givens-      | in_instance_decl = []-      | otherwise        = filterOut is_minimal givens--    -- See #15232-    is_type_error id = isTopLevelUserTypeError (idType id)--    is_improving pred -- (transSuperClasses p) does not include p-      = any isImprovementPred (pred : transSuperClasses pred)--{- Note [Redundant constraints in instance decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instance declarations are special in two ways:--* We don't report unused givens if they can give rise to improvement.-  Example (#10100):-    class Add a b ab | a b -> ab, a ab -> b-    instance Add Zero b b-    instance Add a b ab => Add (Succ a) b (Succ ab)-  The context (Add a b ab) for the instance is clearly unused in terms-  of evidence, since the dictionary has no fields.  But it is still-  needed!  With the context, a wanted constraint-     Add (Succ Zero) beta (Succ Zero)-  we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.-  But without the context we won't find beta := Zero.--  This only matters in instance declarations.--* We don't report givens that are a superclass of another given. E.g.-       class Ord r => UserOfRegs r a where ...-       instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where-  The (Ord r) is not redundant, even though it is a superclass of-  (UserOfRegs r CmmReg).  See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.--  Again this is specific to instance declarations.--}---checkBadTelescope :: Implication -> TcS Bool--- True <=> the skolems form a bad telescope--- See Note [Checking telescopes] in GHC.Tc.Types.Constraint-checkBadTelescope (Implic { ic_info  = info-                          , ic_skols = skols })-  | checkTelescopeSkol info-  = do{ skols <- mapM TcS.zonkTyCoVarKind skols-      ; return (go emptyVarSet (reverse skols))}--  | otherwise-  = return False--  where-    go :: TyVarSet   -- skolems that appear *later* than the current ones-       -> [TcTyVar]  -- ordered skolems, in reverse order-       -> Bool       -- True <=> there is an out-of-order skolem-    go _ [] = False-    go later_skols (one_skol : earlier_skols)-      | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols-      = True-      | otherwise-      = go (later_skols `extendVarSet` one_skol) earlier_skols--warnRedundantGivens :: SkolemInfoAnon -> Bool-warnRedundantGivens (SigSkol ctxt _ _)-  = case ctxt of-       FunSigCtxt _ rrc -> reportRedundantConstraints rrc-       ExprSigCtxt rrc  -> reportRedundantConstraints rrc-       _                -> False--  -- To think about: do we want to report redundant givens for-  -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.-warnRedundantGivens (InstSkol {}) = True-warnRedundantGivens _             = False--neededEvVars :: Implication -> TcS Implication--- Find all the evidence variables that are "needed",--- and delete dead evidence bindings---   See Note [Tracking redundant constraints]---   See Note [Delete dead Given evidence bindings]------   - Start from initial_seeds (from nested implications)------   - Add free vars of RHS of all Wanted evidence bindings---     and coercion variables accumulated in tcvs (all Wanted)------   - Generate 'needed', the needed set of EvVars, by doing transitive---     closure through Given bindings---     e.g.   Needed {a,b}---            Given  a = sc_sel a2---            Then a2 is needed too------   - Prune out all Given bindings that are not needed------   - From the 'needed' set, delete ev_bndrs, the binders of the---     evidence bindings, to give the final needed variables----neededEvVars implic@(Implic { ic_given = givens-                            , ic_binds = ev_binds_var-                            , ic_wanted = WC { wc_impl = implics }-                            , ic_need_inner = old_needs })- = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var-      ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var--      ; let seeds1        = foldr add_implic_seeds old_needs implics-            seeds2        = nonDetStrictFoldEvBindMap add_wanted seeds1 ev_binds-                            -- It's OK to use a non-deterministic fold here-                            -- because add_wanted is commutative-            seeds3        = seeds2 `unionVarSet` tcvs-            need_inner    = findNeededEvVars ev_binds seeds3-            live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds-            need_outer    = varSetMinusEvBindMap need_inner live_ev_binds-                            `delVarSetList` givens--      ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds-           -- See Note [Delete dead Given evidence bindings]--      ; traceTcS "neededEvVars" $-        vcat [ text "old_needs:" <+> ppr old_needs-             , text "seeds3:" <+> ppr seeds3-             , text "tcvs:" <+> ppr tcvs-             , text "ev_binds:" <+> ppr ev_binds-             , text "live_ev_binds:" <+> ppr live_ev_binds ]--      ; return (implic { ic_need_inner = need_inner-                       , ic_need_outer = need_outer }) }- where-   add_implic_seeds (Implic { ic_need_outer = needs }) acc-      = needs `unionVarSet` acc--   needed_ev_bind needed (EvBind { eb_lhs = ev_var-                                 , eb_info = info })-     | EvBindGiven{} <- info = ev_var `elemVarSet` needed-     | otherwise = True   -- Keep all wanted bindings--   add_wanted :: EvBind -> VarSet -> VarSet-   add_wanted (EvBind { eb_info = info, eb_rhs = rhs }) needs-     | EvBindGiven{} <- info = needs  -- Add the rhs vars of the Wanted bindings only-     | otherwise = evVarsOfTerm rhs `unionVarSet` needs----------------------------------------------------simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError)--- Simplify any delayed errors: e.g. type and term holes--- NB: At this point we have finished with all the simple---     constraints; they are in wc_simple, not in the inert set.---     So those Wanteds will not rewrite these delayed errors.---     That's probably no bad thing.------     However if we have [W] alpha ~ Maybe a, [W] alpha ~ Int---     and _ : alpha, then we'll /unify/ alpha with the first of---     the Wanteds we get, and thereby report (_ : Maybe a) or---     (_ : Int) unpredictably, depending on which we happen to see---     first.  Doesn't matter much; there is a type error anyhow.---     T17139 is a case in point.-simplifyDelayedErrors = mapBagM simpl_err-  where-    simpl_err :: DelayedError -> TcS DelayedError-    simpl_err (DE_Hole hole) = DE_Hole <$> simpl_hole hole-    simpl_err err@(DE_NotConcrete {}) = return err--    simpl_hole :: Hole -> TcS Hole--     -- See Note [Do not simplify ConstraintHoles]-    simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h--     -- other wildcards should be simplified for printing-     -- we must do so here, and not in the error-message generation-     -- code, because we have all the givens already set up-    simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc })-      = do { ty' <- rewriteType loc ty-           ; traceTcS "simpl_hole" (ppr ty $$ ppr ty')-           ; return (h { hole_ty = ty' }) }--{- Note [Delete dead Given evidence bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As a result of superclass expansion, we speculatively-generate evidence bindings for Givens. E.g.-   f :: (a ~ b) => a -> b -> Bool-   f x y = ...-We'll have-   [G] d1 :: (a~b)-and we'll speculatively generate the evidence binding-   [G] d2 :: (a ~# b) = sc_sel d--Now d2 is available for solving.  But it may not be needed!  Usually-such dead superclass selections will eventually be dropped as dead-code, but:-- * It won't always be dropped (#13032).  In the case of an-   unlifted-equality superclass like d2 above, we generate-       case heq_sc d1 of d2 -> ...-   and we can't (in general) drop that case expression in case-   d1 is bottom.  So it's technically unsound to have added it-   in the first place.-- * Simply generating all those extra superclasses can generate lots of-   code that has to be zonked, only to be discarded later.  Better not-   to generate it in the first place.--   Moreover, if we simplify this implication more than once-   (e.g. because we can't solve it completely on the first iteration-   of simpl_loop), we'll generate all the same bindings AGAIN!--Easy solution: take advantage of the work we are doing to track dead-(unused) Givens, and use it to prune the Given bindings too.  This is-all done by neededEvVars.--This led to a remarkable 25% overall compiler allocation decrease in-test T12227.--But we don't get to discard all redundant equality superclasses, alas;-see #15205.--Note [Do not simplify ConstraintHoles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Before printing the inferred value for a type hole (a _ wildcard in-a partial type signature), we simplify it w.r.t. any Givens. This-makes for an easier-to-understand diagnostic for the user.--However, we do not wish to do this for extra-constraint holes. Here is-the example for why (partial-sigs/should_compile/T12844):--  bar :: _ => FooData rngs-  bar = foo--  data FooData rngs--  class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs--  type family Head (xs :: [k]) where Head (x ': xs) = x--GHC correctly infers that the extra-constraints wildcard on `bar`-should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this-constraint as a Given on the implication constraint for `bar`. (This-implication is emitted by emitResidualConstraints.) The Hole for the _-is stored within the implication's WantedConstraints.  When-simplifyHoles is called, that constraint is already assumed as a-Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r,-r'), Foo rngs), which is disastrous.--Furthermore, there is no need to simplify here: extra-constraints wildcards-are filled in with the output of the solver, in chooseInferredQuantifiers-(choose_psig_context), so they are already simplified. (Contrast to normal-type holes, which are just bound to a meta-variable.) Avoiding the poor output-is simple: just don't simplify extra-constraints wildcards.--This is the only reason we need to track ConstraintHole separately-from TypeHole in HoleSort.--See also Note [Extra-constraint holes in partial type signatures]-in GHC.Tc.Gen.HsType.--Note [Tracking redundant constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-With Opt_WarnRedundantConstraints, GHC can report which-constraints of a type signature (or instance declaration) are-redundant, and can be omitted.  Here is an overview of how it-works.--This is all tested in typecheck/should_compile/T20602 (among-others).------- What is a redundant constraint?--* The things that can be redundant are precisely the Given-  constraints of an implication.--* A constraint can be redundant in two different ways:-  a) It is not needed by the Wanted constraints covered by the-     implication E.g.-       f :: Eq a => a -> Bool-       f x = True  -- Equality not used-  b) It is implied by other givens.  E.g.-       f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary-       g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary--*  To find (a) we need to know which evidence bindings are 'wanted';-   hence the eb_is_given field on an EvBind.--*  To find (b), we use mkMinimalBySCs on the Givens to see if any-   are unnecessary.------- How tracking works--(RC1) When two Givens are the same, we drop the evidence for the one-  that requires more superclass selectors. This is done-  according to 2(c) of Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet.--(RC2) The ic_need fields of an Implic records in-scope (given) evidence-  variables bound by the context, that were needed to solve this-  implication (so far).  See the declaration of Implication.--(RC3) setImplicationStatus:-  When the constraint solver finishes solving all the wanteds in-  an implication, it sets its status to IC_Solved--  - The ics_dead field, of IC_Solved, records the subset of this-    implication's ic_given that are redundant (not needed).--  - We compute which evidence variables are needed by an implication-    in setImplicationStatus.  A variable is needed if-    a) it is free in the RHS of a Wanted EvBind,-    b) it is free in the RHS of an EvBind whose LHS is needed, or-    c) it is in the ics_need of a nested implication.--  - After computing which variables are needed, we then look at the-    remaining variables for internal redundancies. This is case (b)-    from above. This is also done in setImplicationStatus.-    Note that we only look for case (b) if case (a) shows up empty,-    as exemplified below.--  - We need to be careful not to discard an implication-    prematurely, even one that is fully solved, because we might-    thereby forget which variables it needs, and hence wrongly-    report a constraint as redundant.  But we can discard it once-    its free vars have been incorporated into its parent; or if it-    simply has no free vars. This careful discarding is also-    handled in setImplicationStatus.--(RC4) We do not want to report redundant constraints for implications-  that come from quantified constraints.  Example #23323:-     data T a-     instance Show (T a) where ...  -- No context!-     foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int-     bar = foo @T @Eq--  The call to `foo` gives us-    [W] d : (forall a. Eq a => Show (T a))-  To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint:-    forall a. Eq a =>  [W] ds : Show (T a)-  and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a`-  constraint.  But we don't want to report it as redundant!--* Examples:--    f, g, h :: (Eq a, Ord a) => a -> Bool-    f x = x == x-    g x = x > x-    h x = x == x && x > x--    All three will discover that they have two [G] Eq a constraints:-    one as given and one extracted from the Ord a constraint. They will-    both discard the latter, as noted above and in-    Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet.--    The body of f uses the [G] Eq a, but not the [G] Ord a. It will-    report a redundant Ord a using the logic for case (a).--    The body of g uses the [G] Ord a, but not the [G] Eq a. It will-    report a redundant Eq a using the logic for case (a).--    The body of h uses both [G] Ord a and [G] Eq a. Case (a) will-    thus come up with nothing redundant. But then, the case (b)-    check will discover that Eq a is redundant and report this.--    If we did case (b) even when case (a) reports something, then-    we would report both constraints as redundant for f, which is-    terrible.------- Reporting redundant constraints--* GHC.Tc.Errors does the actual warning, in warnRedundantConstraints.--* We don't report redundant givens for *every* implication; only-  for those which reply True to GHC.Tc.Solver.warnRedundantGivens:--   - For example, in a class declaration, the default method *can*-     use the class constraint, but it certainly doesn't *have* to,-     and we don't want to report an error there.  Ditto instance decls.--   - More subtly, in a function definition-       f :: (Ord a, Ord a, Ix a) => a -> a-       f x = rhs-     we do an ambiguity check on the type (which would find that one-     of the Ord a constraints was redundant), and then we check that-     the definition has that type (which might find that both are-     redundant).  We don't want to report the same error twice, so we-     disable it for the ambiguity check.  Hence using two different-     FunSigCtxts, one with the warn-redundant field set True, and the-     other set False in-        - GHC.Tc.Gen.Bind.tcSpecPrag-        - GHC.Tc.Gen.Bind.tcTySig--  This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors-  so that we can discard implication constraints that we don't need.-  So ics_dead consists only of the *reportable* redundant givens.------- Shortcomings--Shortcoming 1.  Consider--  j :: (Eq a, a ~ b) => a -> Bool-  j x = x == x--  k :: (Eq a, b ~ a) => a -> Bool-  k x = x == x--Currently (Nov 2021), j issues no warning, while k says that b ~ a-is redundant. This is because j uses the a ~ b constraint to rewrite-everything to be in terms of b, while k does none of that. This is-ridiculous, but I (Richard E) don't see a good fix.--Shortcoming 2.  Removing a redundant constraint can cause clients to fail to-compile, by making the function more polymoprhic. Consider (#16154)--  f :: (a ~ Bool) => a -> Int-  f x = 3--  g :: String -> Int-  g s = f (read s)--The constraint in f's signature is redundant; not used to typecheck-`f`.  And yet if you remove it, `g` won't compile, because there'll-be an ambiguous variable in `g`.--}--type UnificationDone = Bool--noUnification, didUnification :: UnificationDone-noUnification  = False-didUnification = True---- | Like 'defaultTyVar', but in the TcS monad.-defaultTyVarTcS :: TcTyVar -> TcS UnificationDone-defaultTyVarTcS the_tv-  | isTyVarTyVar the_tv-    -- TyVarTvs should only be unified with a tyvar-    -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar-    -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl-  = return noUnification-  | isRuntimeRepVar the_tv-  = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)-       ; unifyTyVar the_tv liftedRepTy-       ; return didUnification }-  | isLevityVar the_tv-  = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv)-       ; unifyTyVar the_tv liftedDataConTy-       ; return didUnification }-  | isMultiplicityVar the_tv-  = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)-       ; unifyTyVar the_tv ManyTy-       ; return didUnification }-  | otherwise-  = return noUnification  -- the common case--approximateWC :: Bool   -- See Wrinkle (W3) in Note [ApproximateWC]-              -> WantedConstraints-              -> Cts--- Second return value is the depleted wc--- Postcondition: Wanted Cts--- See Note [ApproximateWC]--- See Note [floatKindEqualities vs approximateWC]-approximateWC float_past_equalities wc-  = float_wc False emptyVarSet wc-  where-    float_wc :: Bool           -- True <=> there are enclosing equalities-             -> TcTyCoVarSet   -- Enclosing skolem binders-             -> WantedConstraints -> Cts-    float_wc encl_eqs trapping_tvs (WC { wc_simple = simples, wc_impl = implics })-      = filterBag (is_floatable encl_eqs trapping_tvs) simples `unionBags`-        concatMapBag (float_implic encl_eqs trapping_tvs) implics--    float_implic :: Bool -> TcTyCoVarSet -> Implication -> Cts-    float_implic encl_eqs trapping_tvs imp-      = float_wc new_encl_eqs new_trapping_tvs (ic_wanted imp)-      where-        new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp-        new_encl_eqs = encl_eqs || ic_given_eqs imp == MaybeGivenEqs--    is_floatable encl_eqs skol_tvs ct-       | isGivenCt ct                                = False-       | insolubleCt ct                              = False-       | tyCoVarsOfCt ct `intersectsVarSet` skol_tvs = False-       | otherwise-       = case classifyPredType (ctPred ct) of-           EqPred {}     -> float_past_equalities || not encl_eqs-                                  -- See Wrinkle (W1)-           ClassPred {}  -> True  -- See Wrinkle (W2)-           IrredPred {}  -> True  -- ..both in Note [ApproximateWC]-           ForAllPred {} -> False--{- Note [ApproximateWC]-~~~~~~~~~~~~~~~~~~~~~~~-approximateWC takes a constraint, typically arising from the RHS of a-let-binding whose type we are *inferring*, and extracts from it some-*simple* constraints that we might plausibly abstract over.  Of course-the top-level simple constraints are plausible, but we also float constraints-out from inside, if they are not captured by skolems.--The same function is used when doing type-class defaulting (see the call-to applyDefaultingRules) to extract constraints that might be defaulted.--Wrinkle (W1)-  When inferring most-general types (in simplifyInfer), we-  do *not* float an equality constraint if the implication binds-  equality constraints, because that defeats the OutsideIn story.-  Consider data T a where TInt :: T Int MkT :: T a--         f TInt = 3::Int--  We get the implication (a ~ Int => res ~ Int), where so far we've decided-     f :: T a -> res-  We don't want to float (res~Int) out because then we'll infer-     f :: T a -> Int-  which is only on of the possible types. (GHC 7.6 accidentally *did*-  float out of such implications, which meant it would happily infer-  non-principal types.)--Wrinkle (W2)-  We do allow /class/ constraints to float, even if-  the implication binds equalities.  This is a subtle point: see #23224.-  In principle, a class constraint might ultimately be satisfiable from-  a constraint bound by an implication (see #19106 for an example of this-  kind), but it's extremely obscure and I was unable to construct a-  concrete example.  In any case, in super-subtle cases where this might-  make a difference, you would be much better advised to simply write a-  type signature.--  I included IrredPred here too, for good measure.  In general,-  abstracting over more constraints does no harm.--Wrinkle (W3)-  In findDefaultableGroups we are not worried about the-  most-general type; and we /do/ want to float out of equalities-  (#12797).  Hence the boolean flag to approximateWC.-------- Historical note ------------There used to be a second caveat, driven by #8155--   2. We do not float out an inner constraint that shares a type variable-      (transitively) with one that is trapped by a skolem.  Eg-          forall a.  F a ~ beta, Integral beta-      We don't want to float out (Integral beta).  Doing so would be bad-      when defaulting, because then we'll default beta:=Integer, and that-      makes the error message much worse; we'd get-          Can't solve  F a ~ Integer-      rather than-          Can't solve  Integral (F a)--      Moreover, floating out these "contaminated" constraints doesn't help-      when generalising either. If we generalise over (Integral b), we still-      can't solve the retained implication (forall a. F a ~ b).  Indeed,-      arguably that too would be a harder error to understand.--But this transitive closure stuff gives rise to a complex rule for-when defaulting actually happens, and one that was never documented.-Moreover (#12923), the more complex rule is sometimes NOT what-you want.  So I simply removed the extra code to implement the-contamination stuff.  There was zero effect on the testsuite (not even #8155).------- End of historical note -------------Note [DefaultTyVar]-~~~~~~~~~~~~~~~~~~~-defaultTyVar is used on any un-instantiated meta type variables to-default any RuntimeRep variables to LiftedRep.  This is important-to ensure that instance declarations match.  For example consider--     instance Show (a->b)-     foo x = show (\_ -> True)--Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),-and that won't match the typeKind (*) in the instance decl.  See tests-tc217 and tc175.--We look only at touchable type variables. No further constraints-are going to affect these type variables, so it's time to do it by-hand.  However we aren't ready to default them fully to () or-whatever, because the type-class defaulting rules have yet to run.--An alternate implementation would be to emit a Wanted constraint setting-the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.--Note [Promote _and_ default when inferring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we are inferring a type, we simplify the constraint, and then use-approximateWC to produce a list of candidate constraints.  Then we MUST--  a) Promote any meta-tyvars that have been floated out by-     approximateWC, to restore invariant (WantedInv) described in-     Note [TcLevel invariants] in GHC.Tc.Utils.TcType.--  b) Default the kind of any meta-tyvars that are not mentioned in-     in the environment.--To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we-have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it-should!  If we don't solve the constraint, we'll stupidly quantify over-(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over-(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332.-#7641 is a simpler example.--Note [Promoting unification variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we float an equality out of an implication we must "promote" free-unification variables of the equality, in order to maintain Invariant-(WantedInv) from Note [TcLevel invariants] in GHC.Tc.Types.TcType.--This is absolutely necessary. Consider the following example. We start-with two implications and a class with a functional dependency.--    class C x y | x -> y-    instance C [a] [a]--    (I1)      [untch=beta]forall b. 0 => F Int ~ [beta]-    (I2)      [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]--We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2.-They may react to yield that (beta := [alpha]) which can then be pushed inwards-the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that-(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable-beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:--    class C x y | x -> y where-     op :: x -> y -> ()--    instance C [a] [a]--    type family F a :: *--    h :: F Int -> ()-    h = undefined--    data TEx where-      TEx :: a -> TEx--    f (x::beta) =-        let g1 :: forall b. b -> ()-            g1 _ = h [x]-            g2 z = case z of TEx y -> (h [[undefined]], op x [y])-        in (g1 '3', g2 undefined)---*********************************************************************************-*                                                                               *-*                          Defaulting and disambiguation                        *-*                                                                               *-*********************************************************************************--Note [How type-class constraints are defaulted]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Type-class defaulting deals with the situation where we have unsolved-constraints like (Num alpha), where `alpha` is a unification variable.  We want-to pick a default for `alpha`, such as `alpha := Int` to resolve the ambiguity.--Type-class defaulting is guided by the `DefaultEnv`: see Note [Named default declarations]-in GHC.Tc.Gen.Default--The entry point for defaulting the unsolved constraints is `applyDefaultingRules`,-which depends on `disambigGroup`, which in turn depends on workhorse-`disambigProposalSequences`. The latter is also used by defaulting plugins through-`disambigMultiGroup` (see Note [Defaulting plugins] below).--The algorithm works as follows. Let S be the complete set of unsolved-constraints, and initialize Sx to an empty set of constraints. For every type-variable `v` that is free in S:--1. Define Cv = { Ci v | Ci v ∈ S }, the subset of S consisting of all constraints in S of-   form (Ci v), where Ci is a single-parameter type class.  (We do no defaulting for-   multi-parameter type classes.)--2. Define Dv, by extending Cv with the superclasses of every Ci in Cv--3. Define Ev, by filtering Dv to contain only classes with a default declaration.--4. For each Ci in Ev, if Ci has a non-empty default list in the `DefaultEnv`, find the first-   type T in the default list for Ci for which, for every (Ci v) in Cv, the constraint (Ci T)-  is soluble.--5. If there is precisely one type T in the resulting type set, resolve the ambiguity by adding-   a constraint (v~ Ti) constraint to a set Sx; otherwise report a static error.--Note [Defaulting plugins]-~~~~~~~~~~~~~~~~~~~~~~~~~-Defaulting plugins enable extending or overriding the defaulting-behaviour. In `applyDefaultingRules`, before the built-in defaulting-mechanism runs, the loaded defaulting plugins are passed the-`WantedConstraints` and get a chance to propose defaulting assignments-based on them.--Proposals are represented as `[DefaultingProposal]` with each proposal-consisting of a type variable to fill-in, the list of defaulting types to-try in order, and a set of constraints to check at each try. This is-the same representation (albeit in a nicely packaged-up data type) as-the candidates generated by the built-in defaulting mechanism, so the-actual trying of proposals is done by the same `disambigGroup` function.--Wrinkle (DP1): The role of `WantedConstraints`--  Plugins are passed `WantedConstraints` that can perhaps be-  progressed on by defaulting. But a defaulting plugin is not a solver-  plugin, its job is to provide defaulting proposals, i.e. mappings of-  type variable to types. How do plugins know which type variables-  they are supposed to default?--  The `WantedConstraints` passed to the defaulting plugin are zonked-  beforehand to ensure all remaining metavariables are unfilled. Thus,-  the `WantedConstraints` serve a dual purpose: they are both the-  constraints of the given context that can act as hints to the-  defaulting, as well as the containers of the type variables under-  consideration for defaulting.--Wrinkle (DP2): Interactions between defaulting mechanisms--  In the general case, we have multiple defaulting plugins loaded and-  there is also the built-in defaulting mechanism. In this case, we-  have to be careful to keep the `WantedConstraints` passed to the-  plugins up-to-date by zonking between successful defaulting-  rounds. Otherwise, two plugins might come up with a defaulting-  proposal for the same metavariable; if the first one is accepted by-  `disambigGroup` (thus the meta gets filled), the second proposal-  becomes invalid (see #23821 for an example).---}--tryTypeClassDefaulting :: WantedConstraints -> TcS WantedConstraints-tryTypeClassDefaulting wc-  | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]-  = return wc-  | otherwise  -- See Note [When to do type-class defaulting]-  = do { something_happened <- applyDefaultingRules wc-                               -- See Note [Top-level Defaulting Plan]-       ; solveAgainIf something_happened wc }--applyDefaultingRules :: WantedConstraints -> TcS Bool--- True <=> I did some defaulting, by unifying a meta-tyvar--- Input WantedConstraints are not necessarily zonked--- See Note [How type-class constraints are defaulted]--applyDefaultingRules wanteds-  | isEmptyWC wanteds-  = return False-  | otherwise-  = do { (default_env, extended_rules) <- getDefaultInfo-       ; wanteds                       <- TcS.zonkWC wanteds--       ; tcg_env <- TcS.getGblEnv-       ; let plugins = tcg_defaulting_plugins tcg_env-             default_tys = defaultList default_env-             -- see Note [Named default declarations] in GHC.Tc.Gen.Default--       -- Run any defaulting plugins-       -- See Note [Defaulting plugins] for an overview-       ; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else-           do {-             ; traceTcS "defaultingPlugins {" (ppr wanteds)-             ; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins-             ; traceTcS "defaultingPlugins }" (ppr defaultedGroups)-             ; return (wanteds, defaultedGroups)-             }--       ; let groups = findDefaultableGroups (default_tys, extended_rules) wanteds--       ; traceTcS "applyDefaultingRules {" $-                  vcat [ text "wanteds =" <+> ppr wanteds-                       , text "groups  =" <+> ppr groups-                       , text "info    =" <+> ppr (default_tys, extended_rules) ]--       ; something_happeneds <- mapM (disambigGroup wanteds default_tys) groups--       ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)--       ; return $ or something_happeneds || or plugin_defaulted }--    where-      run_defaulting_plugin wanteds p-          = do { groups <- runTcPluginTcS (p wanteds)-               ; defaultedGroups <--                    filterM (\g -> disambigMultiGroup-                                   wanteds-                                   (deProposalCts g)-                                   (ProposalSequence (Proposal <$> deProposals g)))-                    groups-               ; traceTcS "defaultingPlugin " $ ppr defaultedGroups-               ; case defaultedGroups of-                 [] -> return (wanteds, False)-                 _  -> do-                     -- If a defaulting plugin solves any tyvars, some of the wanteds-                     -- will have filled-in metavars by now (see wrinkle DP2 of-                     -- Note [Defaulting plugins]). So we re-zonk to make sure later-                     -- defaulting doesn't try to solve the same metavars.-                     wanteds' <- TcS.zonkWC wanteds-                     return (wanteds', True) }--findDefaultableGroups-    :: ( [ClassDefaults]-       , Bool )            -- extended default rules-    -> WantedConstraints   -- Unsolved-    -> [(TyVar, [Ct])]-findDefaultableGroups (default_tys, extended_defaults) wanteds-  | null default_tys-  = []-  | otherwise-  = [ (tv, map fstOf3 group)-    | group'@((_,_,tv) :| _) <- unary_groups-    , let group = toList group'-    , defaultable_tyvar tv-    , defaultable_classes (map sndOf3 group) ]-  where-    simples                = approximateWC True wanteds-    (unaries, non_unaries) = partitionWith find_unary (bagToList simples)-    unary_groups           = equivClasses cmp_tv unaries--    unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints-    unaries      :: [(Ct, Class, TcTyVar)]          -- (C tv) constraints-    non_unaries  :: [Ct]                            -- and *other* constraints--    -- Finds unary type-class constraints-    -- But take account of polykinded classes like Typeable,-    -- which may look like (Typeable * (a:*))   (#8931)-    -- step (1) in Note [How type-class constraints are defaulted]-    find_unary :: Ct -> Either (Ct, Class, TyVar) Ct-    find_unary cc-        | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)-        , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys-              -- Ignore invisible arguments for this purpose-        , Just tv <- getTyVar_maybe ty-        , isMetaTyVar tv  -- We might have runtime-skolems in GHCi, and-                          -- we definitely don't want to try to assign to those!-        = Left (cc, cls, tv)-    find_unary cc = Right cc  -- Non unary or non dictionary--    bad_tvs :: TcTyCoVarSet  -- TyVars mentioned by non-unaries-    bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries--    cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2--    defaultable_tyvar :: TcTyVar -> Bool-    defaultable_tyvar tv-        = let b1 = isTyConableTyVar tv  -- Note [Avoiding spurious errors]-              b2 = not (tv `elemVarSet` bad_tvs)-          in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults]--    -- Determines if any of the given type class constructors is in default_tys-    -- step (3) in Note [How type-class constraints are defaulted]-    defaultable_classes :: [Class] -> Bool-    defaultable_classes clss = not . null . intersect clss $ map cd_class default_tys------------------------------------ | 'Proposal's to be tried in sequence until the first one that succeeds-newtype ProposalSequence = ProposalSequence{getProposalSequence :: [Proposal]}---- | An atomic set of proposed type assignments to try applying all at once-newtype Proposal = Proposal [(TcTyVar, Type)]--instance Outputable ProposalSequence where-  ppr (ProposalSequence proposals) = ppr proposals-instance Outputable Proposal where-  ppr (Proposal assignments) = ppr assignments--disambigGroup :: WantedConstraints -- ^ Original constraints, for diagnostic purposes-              -> [ClassDefaults]   -- ^ The default classes and types-              -> (TcTyVar, [Ct])   -- ^ All constraints sharing same type variable-              -> TcS Bool   -- True <=> something happened, reflected in ty_binds-disambigGroup orig_wanteds default_ctys (tv, wanteds)-  = disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent-  where-    proposalSequences = [ ProposalSequence [Proposal [(tv, ty)] | ty <- tys]-                        | ClassDefaults{cd_types = tys} <- defaultses ]-    allConsistent ((_, sub) :| subs) = all (eqSubAt tv sub . snd) subs-    defaultses =-      [ defaults | defaults@ClassDefaults{cd_class = cls} <- default_ctys-                 , any (isDictForClass (className cls)) wanteds ]-    isDictForClass clcon ct = any ((clcon ==) . className . fst) (getClassPredTys_maybe $ ctPred ct)-    eqSubAt :: TcTyVar -> Subst -> Subst -> Bool-    eqSubAt tvar s1 s2 = or $ liftA2 tcEqType (lookupTyVar s1 tvar) (lookupTyVar s2 tvar)---- See Note [How type-class constraints are defaulted]-disambigMultiGroup :: WantedConstraints    -- ^ Original constraints, for diagnostic purposes-                   -> [Ct]                 -- ^ check these are solved by defaulting-                   -> ProposalSequence     -- ^ defaulting type assignments to try-                   -> TcS Bool   -- True <=> something happened, reflected in ty_binds-disambigMultiGroup orig_wanteds wanteds proposalSequence-  = disambigProposalSequences orig_wanteds wanteds [proposalSequence] (const True)--disambigProposalSequences :: WantedConstraints   -- ^ Original constraints, for diagnostic purposes-                          -> [Ct]                -- ^ Check these are solved by defaulting-                          -> [ProposalSequence]  -- ^ The sequences of assignment proposals-                          -> (NonEmpty ([TcTyVar], Subst) -> Bool)-                                                 -- ^ Predicate for successful assignments-                          -> TcS Bool   -- True <=> something happened, reflected in ty_binds-disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent-  = do { traverse_ (traverse_ reportInvalidDefaultedTyVars . getProposalSequence) proposalSequences-       ; fake_ev_binds_var <- TcS.newTcEvBinds-       ; tclvl             <- TcS.getTcLevel-       -- Step (4) in Note [How type-class constraints are defaulted]-       ; successes <- fmap catMaybes $-                      nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $-                      mapM firstSuccess proposalSequences-       ; traceTcS "disambigProposalSequences" (vcat [ ppr wanteds-                                                    , ppr proposalSequences-                                                    , ppr successes ])-       -- Step (5) in Note [How type-class constraints are defaulted]-       ; case successes of-           success@(tvs, subst) : rest-             | allConsistent (success :| rest)-             -> do { applyDefaultSubst tvs subst-                   ; let warn tv = mapM_ (warnDefaulting wanteds tv) (lookupTyVar subst tv)-                   ; wrapWarnTcS $ mapM_ warn tvs-                   ; traceTcS "disambigProposalSequences succeeded }" (ppr proposalSequences)-                   ; return True }-           _ ->-             do { traceTcS "disambigProposalSequences failed }" (ppr proposalSequences)-                ; return False } }-  where-    reportInvalidDefaultedTyVars :: Proposal -> TcS ()-    firstSuccess :: ProposalSequence -> TcS (Maybe ([TcTyVar], Subst))-    firstSuccess (ProposalSequence proposals)-      = getFirst <$> foldMapM (fmap First . tryDefaultGroup wanteds) proposals-    reportInvalidDefaultedTyVars proposal@(Proposal assignments)-      = do { let tvs = fst <$> assignments-             ; invalid_tvs <- filterOutM TcS.isUnfilledMetaTyVar tvs-             ; traverse_ (errInvalidDefaultedTyVar orig_wanteds proposal) (nonEmpty invalid_tvs) }--applyDefaultSubst :: [TcTyVar] -> Subst -> TcS ()-applyDefaultSubst tvs subst =-  do { deep_tvs <- filterM TcS.isUnfilledMetaTyVar $ nonDetEltsUniqSet $ closeOverKinds (mkVarSet tvs)-     ; forM_ deep_tvs $ \ tv -> mapM_ (unifyTyVar tv) (lookupVarEnv (getTvSubstEnv subst) tv)-     }--tryDefaultGroup :: [Ct]       -- ^ check these are solved by defaulting-                -> Proposal   -- ^ defaulting type assignments to try-                -> TcS (Maybe ([TcTyVar], Subst))  -- ^ successful substitutions, *not* reflected in ty_binds-tryDefaultGroup wanteds (Proposal assignments)-          | let (tvs, default_tys) = unzip assignments-          , Just subst <- tcMatchTyKis (mkTyVarTys tvs) default_tys-            -- Make sure the kinds match too; hence this call to tcMatchTyKi-            -- E.g. suppose the only constraint was (Typeable k (a::k))-            -- With the addition of polykinded defaulting we also want to reject-            -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.-          = do { lcl_env <- TcS.getLclEnv-               ; tc_lvl <- TcS.getTcLevel-               ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)-               -- Equality constraints are possible due to type defaulting plugins-               ; wanted_evs <- sequence [ newWantedNC loc rewriters pred'-                                        | wanted <- wanteds-                                        , CtWanted { ctev_pred = pred-                                                   , ctev_rewriters = rewriters }-                                            <- return (ctEvidence wanted)-                                        , let pred' = substTy subst pred ]-               ; residual_wc <- solveSimpleWanteds $ listToBag $ map mkNonCanonical wanted_evs-               ; return $ if isEmptyWC residual_wc then Just (tvs, subst) else Nothing }--          | otherwise-          = return Nothing--errInvalidDefaultedTyVar :: WantedConstraints -> Proposal -> NonEmpty TcTyVar -> TcS ()-errInvalidDefaultedTyVar wanteds (Proposal assignments) problematic_tvs-  = failTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_assignments tidy_problems-  where-    proposal_tvs = concatMap (\(tv, ty) -> tv : tyCoVarsOfTypeList ty) assignments-    tidy_env = tidyFreeTyCoVars emptyTidyEnv $ proposal_tvs ++ NE.toList problematic_tvs-    tidy_wanteds = map (tidyCt tidy_env) $ flattenWC wanteds-    tidy_assignments = [(tidyTyCoVarOcc tidy_env tv, tidyType tidy_env ty) | (tv, ty) <- assignments]-    tidy_problems = fmap (tidyTyCoVarOcc tidy_env) problematic_tvs--    flattenWC :: WantedConstraints -> [Ct]-    flattenWC (WC { wc_simple = cts, wc_impl = impls })-      = ctsElts cts ++ concatMap (flattenWC . ic_wanted) impls---- In interactive mode, or with -XExtendedDefaultRules,--- we default Show a to Show () to avoid gratuitous errors on "show []"-isInteractiveClass :: Bool   -- -XOverloadedStrings?-                   -> Class -> Bool-isInteractiveClass ovl_strings cls-    = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys)--    -- isNumClass adds IsString to the standard numeric classes,-    -- when -XOverloadedStrings is enabled-isNumClass :: Bool   -- -XOverloadedStrings?-           -> Class -> Bool-isNumClass ovl_strings cls-  = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))---{--Note [Avoiding spurious errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When doing the unification for defaulting, we check for skolem-type variables, and simply don't default them.  For example:-   f = (*)      -- Monomorphic-   g :: Num a => a -> a-   g x = f x x-Here, we get a complaint when checking the type signature for g,-that g isn't polymorphic enough; but then we get another one when-dealing with the (Num a) context arising from f's definition;-we try to unify a with Int (to default it), but find that it's-already been unified with the rigid variable from g's type sig.--Note [Multi-parameter defaults]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-With -XExtendedDefaultRules, we default only based on single-variable-constraints, but do not exclude from defaulting any type variables which also-appear in multi-variable constraints. This means that the following will-default properly:--   default (Integer, Double)--   class A b (c :: Symbol) where-      a :: b -> Proxy c--   instance A Integer c where a _ = Proxy--   main = print (a 5 :: Proxy "5")--Note that if we change the above instance ("instance A Integer") to-"instance A Double", we get an error:--   No instance for (A Integer "5")--This is because the first defaulted type (Integer) has successfully satisfied-its single-parameter constraints (in this case Num).+       simplifyTop, simplifyTopImplic,+       simplifyInteractive,+       solveEqualities,+       pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX,+       reportUnsolvedEqualities,+       simplifyWantedsTcM,+       tcCheckGivens,+       tcCheckWanteds,+       tcNormalise,+       approximateWC,    -- Exported for plugins to use++       captureTopConstraints, emitResidualConstraints,++       simplifyTopWanteds,++       promoteTyVarSet, simplifyAndEmitFlatConstraints++  ) where++import GHC.Prelude++import GHC.Tc.Errors+import GHC.Tc.Errors.Types+import GHC.Tc.Types.Evidence+import GHC.Tc.Solver.Solve   ( solveSimpleGivens, solveSimpleWanteds+                             , solveWanteds, simplifyWantedsTcM )+import GHC.Tc.Solver.Default ( tryDefaulting, tryDefaultingForAmbiguityCheck+                             , isInteractiveClass )+import GHC.Tc.Solver.Dict    ( makeSuperClasses )+import GHC.Tc.Solver.Rewrite ( rewriteType )+import GHC.Tc.Utils.Unify+import GHC.Tc.Utils.TcMType as TcM+import GHC.Tc.Utils.Monad   as TcM+import GHC.Tc.Zonk.TcType     as TcM+import GHC.Tc.Solver.InertSet+import GHC.Tc.Solver.Monad  as TcS+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.CtLoc( mkGivenLoc )+import GHC.Tc.Instance.FunDeps+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType++import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.Ppr+import GHC.Core.TyCon    ( TyConBinder )++import GHC.Types.Name+import GHC.Types.Id++import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Basic+import GHC.Types.Error++import GHC.Driver.DynFlags( DynFlags, xopt )+import GHC.Driver.Flags( WarningFlag(..) )+import GHC.Utils.Panic+import GHC.Utils.Outputable+import GHC.Utils.Misc( filterOut )++import GHC.Data.Bag++import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.List          ( partition )+import GHC.Data.Maybe     ( mapMaybe )++{-+*********************************************************************************+*                                                                               *+*                           External interface                                  *+*                                                                               *+*********************************************************************************+-}++captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)+-- (captureTopConstraints m) runs m, and returns the type constraints it+-- generates plus the constraints produced by static forms inside.+-- If it fails with an exception, it reports any insolubles+-- (out of scope variables) before doing so+--+-- captureTopConstraints is used exclusively by GHC.Tc.Module at the top+-- level of a module.+--+-- Importantly, if captureTopConstraints propagates an exception, it+-- reports any insoluble constraints first, lest they be lost+-- altogether.  This is important, because solveEqualities (maybe+-- other things too) throws an exception without adding any error+-- messages; it just puts the unsolved constraints back into the+-- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors]+-- #16376 is an example of what goes wrong if you don't do this.+--+-- NB: the caller should bring any environments into scope before+-- calling this, so that the reportUnsolved has access to the most+-- complete GlobalRdrEnv+captureTopConstraints thing_inside+  = do { static_wc_var <- TcM.newTcRef emptyWC ;+       ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $+                          TcM.tryCaptureConstraints thing_inside+       ; stWC <- TcM.readTcRef static_wc_var++       -- See GHC.Tc.Utils.Monad Note [Constraints and errors]+       -- If the thing_inside threw an exception, but generated some insoluble+       -- constraints, report the latter before propagating the exception+       -- Otherwise they will be lost altogether+       ; case mb_res of+           Just res -> return (res, lie `andWC` stWC)+           Nothing  -> do { _ <- simplifyTop lie; failM } }+                -- This call to simplifyTop is the reason+                -- this function is here instead of GHC.Tc.Utils.Monad+                -- We call simplifyTop so that it does defaulting+                -- (esp of runtime-reps) before reporting errors++simplifyTopImplic :: Bag Implication -> TcM ()+simplifyTopImplic implics+  = do { empty_binds <- simplifyTop (mkImplicWC implics)++       -- Since all the inputs are implications the returned bindings will be empty+       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)++       ; return () }++simplifyTop :: WantedConstraints -> TcM (Bag EvBind)+-- Simplify top-level constraints+-- Usually these will be implications,+-- but when there is nothing to quantify we don't wrap+-- in a degenerate implication, so we do that here instead+simplifyTop wanteds+  = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds+       ; ((final_wc, unsafe_ol), binds1) <- runTcS $+            do { final_wc <- simplifyTopWanteds wanteds+               ; unsafe_ol <- getSafeOverlapFailures+               ; return (final_wc, unsafe_ol) }+       ; traceTc "End simplifyTop }" empty++       ; binds2 <- reportUnsolved final_wc++       ; traceTc "reportUnsolved (unsafe overlapping) {" empty+       ; unless (isEmptyBag unsafe_ol) $ do {+           -- grab current error messages and clear, warnAllUnsolved will+           -- update error messages which we'll grab and then restore saved+           -- messages.+           ; errs_var  <- getErrsVar+           ; saved_msg <- TcM.readTcRef errs_var+           ; TcM.writeTcRef errs_var emptyMessages++           ; warnAllUnsolved $ emptyWC { wc_simple = fmap CDictCan unsafe_ol }++           ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var+           ; TcM.writeTcRef errs_var saved_msg+           ; recordUnsafeInfer (mkMessages whyUnsafe)+           }+       ; traceTc "reportUnsolved (unsafe overlapping) }" empty++       ; return (evBindMapBinds binds1 `unionBags` binds2) }++pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a+-- Push level, and solve all resulting equalities+-- If there are any unsolved equalities, report them+-- and fail (in the monad)+--+-- Panics if we solve any non-equality constraints.  (In runTCSEqualities+-- we use an error thunk for the evidence bindings.)+pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside+  = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX+                                      "pushLevelAndSolveEqualities" thing_inside+       ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted+       ; return res }++pushLevelAndSolveEqualitiesX :: String -> TcM a+                             -> TcM (TcLevel, WantedConstraints, a)+-- Push the level, gather equality constraints, and then solve them.+-- Returns any remaining unsolved equalities.+-- Does not report errors.+--+-- Panics if we solve any non-equality constraints.  (In runTCSEqualities+-- we use an error thunk for the evidence bindings.)+pushLevelAndSolveEqualitiesX callsite thing_inside+  = do { traceTc "pushLevelAndSolveEqualitiesX {" (text "Called from" <+> text callsite)+       ; (tclvl, (wanted, res))+            <- pushTcLevelM $+               do { (res, wanted) <- captureConstraints thing_inside+                  ; wanted <- runTcSEqualities (simplifyTopWanteds wanted)+                  ; return (wanted,res) }+       ; traceTc "pushLevelAndSolveEqualities }" (vcat [ text "Residual:" <+> ppr wanted+                                                       , text "Level:" <+> ppr tclvl ])+       ; return (tclvl, wanted, res) }++-- | Type-check a thing that emits only equality constraints, solving any+-- constraints we can and re-emitting constraints that we can't.+-- Use this variant only when we'll get another crack at it later+-- See Note [Failure in local type signatures]+--+-- Panics if we solve any non-equality constraints.  (In runTCSEqualities+-- we use an error thunk for the evidence bindings.)+solveEqualities :: String -> TcM a -> TcM a+solveEqualities callsite thing_inside+  = do { traceTc "solveEqualities {" (text "Called from" <+> text callsite)+       ; (res, wanted)   <- captureConstraints thing_inside+       ; simplifyAndEmitFlatConstraints wanted+            -- simplifyAndEmitFlatConstraints fails outright unless+            --  the only unsolved constraints are soluble-looking+            --  equalities that can float out+       ; traceTc "solveEqualities }" empty+       ; return res }++simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM ()+-- See Note [Failure in local type signatures]+simplifyAndEmitFlatConstraints wanted+  = do { -- Solve and zonk to establish the+         -- preconditions for floatKindEqualities+         wanted <- runTcSEqualities (solveWanteds wanted)+       ; wanted <- TcM.liftZonkM $ TcM.zonkWC wanted++       ; traceTc "emitFlatConstraints {" (ppr wanted)+       ; case floatKindEqualities wanted of+           Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted)+                         -- Emit the bad constraints, wrapped in an implication+                         -- See Note [Wrapping failing kind equalities]+                         ; tclvl  <- TcM.getTcLevel+                         ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted+                                        --                  ^^^^^^   |  ^^^^^^^^^^^^^^^^^+                                        -- it's OK to use unkSkol    |  we must increase the TcLevel,+                                        -- because we don't bind     |  as explained in+                                        -- any skolem variables here |  Note [Wrapping failing kind equalities]+                         ; TcM.emitImplication implic+                         ; failM }+           Just (simples, errs)+              -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)+                    ; traceTc "emitFlatConstraints }" $+                      vcat [ text "simples:" <+> ppr simples+                           , text "errs:   " <+> ppr errs ]+                      -- Holes and other delayed errors don't need promotion+                    ; emitDelayedErrors errs+                    ; emitSimples simples } }++floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError)+-- Float out all the constraints from the WantedConstraints,+-- Return Nothing if any constraints can't be floated (captured+-- by skolems), or if there is an insoluble constraint, or+-- IC_Telescope telescope error+-- Precondition 1: we have tried to solve the 'wanteds', both so that+--    the ic_status field is set, and because solving can make constraints+--    more floatable.+-- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities+--    is not monadic+-- See Note [floatKindEqualities vs approximateWC]+floatKindEqualities wc = float_wc emptyVarSet wc+  where+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError)+    float_wc trapping_tvs (WC { wc_simple = simples+                              , wc_impl = implics+                              , wc_errors = errs })+      | all is_floatable simples+      = do { (inner_simples, inner_errs)+                <- flatMapBagPairM (float_implic trapping_tvs) implics+           ; return ( simples `unionBags` inner_simples+                    , errs `unionBags` inner_errs) }+      | otherwise+      = Nothing+      where+        is_floatable ct+           | insolubleCt ct = False+           | otherwise      = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs++    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError)+    float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs+                                      , ic_skols = skols, ic_status = status })+      | isInsolubleStatus status+      = Nothing   -- A short cut /plus/ we must keep track of IC_BadTelescope+      | otherwise+      = do { (simples, holes) <- float_wc new_trapping_tvs wanted+           ; when (not (isEmptyBag simples) && given_eqs == MaybeGivenEqs) $+             Nothing+                 -- If there are some constraints to float out, but we can't+                 -- because we don't float out past local equalities+                 -- (c.f GHC.Tc.Solver.approximateWC), then fail+           ; return (simples, holes) }+      where+        new_trapping_tvs = trapping_tvs `extendVarSetList` skols+++{- Note [Failure in local type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When kind checking a type signature, we like to fail fast if we can't+solve all the kind equality constraints, for two reasons:++  * A kind-bogus type signature may cause a cascade of knock-on+    errors if we let it pass++  * More seriously, we don't have a convenient term-level place to add+    deferred bindings for unsolved kind-equality constraints.  In+    earlier GHCs this led to un-filled-in coercion holes, which caused+    GHC to crash with "fvProv falls into a hole" See #11563, #11520,+    #11516, #11399++But what about /local/ type signatures, mentioning in-scope type+variables for which there might be 'given' equalities?  For these we+might not be able to solve all the equalities locally. Here's an+example (T15076b):++  class (a ~ b) => C a b+  data SameKind :: k -> k -> Type where { SK :: SameKind a b }++  bar :: forall (a :: Type) (b :: Type).+         C a b => Proxy a -> Proxy b -> ()+  bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y)++Consider the type signature on 'undefined'. It's ill-kinded unless+a~b.  But the superclass of (C a b) means that indeed (a~b). So all+should be well. BUT it's hard to see that when kind-checking the signature+for undefined.  We want to emit a residual (a~b) constraint, to solve+later.++Another possibility is that we might have something like+   F alpha ~ [Int]+where alpha is bound further out, which might become soluble+"later" when we learn more about alpha.  So we want to emit+those residual constraints.++BUT it's no good simply wrapping all unsolved constraints from+a type signature in an implication constraint to solve later. The+problem is that we are going to /use/ that signature, including+instantiate it.  Say we have+     f :: forall a.  (forall b. blah) -> blah2+     f x = <body>+To typecheck the definition of f, we have to instantiate those+foralls.  Moreover, any unsolved kind equalities will be coercion+holes in the type.  If we naively wrap them in an implication like+     forall a. (co1:k1~k2,  forall b.  co2:k3~k4)+hoping to solve it later, we might end up filling in the holes+co1 and co2 with coercions involving 'a' and 'b' -- but by now+we've instantiated the type.  Chaos!++Moreover, the unsolved constraints might be skolem-escape things, and+if we proceed with f bound to a nonsensical type, we get a cascade of+follow-up errors. For example polykinds/T12593, T15577, and many others.++So here's the plan (see tcHsSigType):++* pushLevelAndSolveEqualitiesX: try to solve the constraints++* kindGeneraliseSome: do kind generalisation++* buildTvImplication: build an implication for the residual, unsolved+  constraint++* simplifyAndEmitFlatConstraints: try to float out every unsolved equality+  inside that implication, in the hope that it constrains only global+  type variables, not the locally-quantified ones.++  * If we fail, or find an insoluble constraint, emit the implication,+    so that the errors will be reported, and fail.++  * If we succeed in floating all the equalities, promote them and+    re-emit them as flat constraint, not wrapped at all (since they+    don't mention any of the quantified variables.++* Note that this float-and-promote step means that anonymous+  wildcards get floated to top level, as we want; see+  Note [Checking partial type signatures] in GHC.Tc.Gen.HsType.++All this is done:++* In GHC.Tc.Gen.HsType.tcHsSigType, as above++* solveEqualities. Use this when there no kind-generalisation+  step to complicate matters; then we don't need to push levels,+  and can solve the equalities immediately without needing to+  wrap it in an implication constraint.  (You'll generally see+  a kindGeneraliseNone nearby.)++* In GHC.Tc.TyCl and GHC.Tc.TyCl.Instance; see calls to+  pushLevelAndSolveEqualitiesX, followed by quantification, and+  then reportUnsolvedEqualities.++  NB: we call reportUnsolvedEqualities before zonkTcTypeToType+  because the latter does not expect to see any un-filled-in+  coercions, which will happen if we have unsolved equalities.+  By calling reportUnsolvedEqualities first, which fails after+  reporting errors, we avoid that happening.++See also #18062, #11506++Note [Wrapping failing kind equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In simplifyAndEmitFlatConstraints, if we fail to get down to simple+flat constraints we will+* re-emit the constraints so that they are reported+* fail in the monad+But there is a Terrible Danger that, if -fdefer-type-errors is on, and+we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll+report only a warning and proceed with compilation.  But if we ever fail+in the monad it should be fatal; we should report an error and stop after+the type checker.  If not, chaos results: #19142.++Our solution is this:+* Even with -fdefer-type-errors, inside an implication with no place for+  value bindings (ic_binds = CoEvBindsVar), report failing equalities as+  errors.  We have to do this anyway; see GHC.Tc.Errors+  Note [Failing equalities with no evidence bindings].++* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication+  to wrap the failing constraint in a degenerate implication (no+  skolems, no theta), with ic_binds = CoEvBindsVar.  This setting of+  `ic_binds` means that any failing equalities will lead to an+  error not a warning, irrespective of -fdefer-type-errors: see+  Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors,+  and `maybeSwitchOffDefer` in that module.++  We still take care to bump the TcLevel of the implication.  Partly,+  that ensures that nested implications have increasing level numbers+  which seems nice.  But more specifically, suppose the outer level+  has a Given `(C ty)`, which has pending (not-yet-expanded)+  superclasses. Consider what happens when we process this implication+  constraint (which we have re-emitted) in that context:+    - in the inner implication we'll call `getPendingGivenScs`,+    - we /do not/ want to get the `(C ty)` from the outer level,+    lest we try to add an evidence term for the superclass,+    which we can't do because we have specifically set+    `ic_binds` = `CoEvBindsVar`.+    - as `getPendingGivenSCcs is careful to only get Givens from+    the /current/ level, and we bumped the `TcLevel` of the implication,+    we're OK.++  TL;DR: bump the `TcLevel` when creating the nested implication.+  If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043).+++We re-emit the implication rather than reporting the errors right now,+so that the error messages are improved by other solving and defaulting.+e.g. we prefer+    Cannot match 'Type->Type' with 'Type'+to  Cannot match 'Type->Type' with 'TYPE r0'+++Note [floatKindEqualities vs approximateWC]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+floatKindEqualities and approximateWC are strikingly similar to each+other, but++* floatKindEqualites tries to float /all/ equalities, and fails if+  it can't, or if any implication is insoluble.+* approximateWC just floats out any constraints+  (not just equalities) that can float; it never fails.+-}+++reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel+                         -> WantedConstraints -> TcM ()+-- Reports all unsolved wanteds provided; fails in the monad if there are any.+--+-- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to+-- provide skolem info for any errors.+reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+  = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted++report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel+                           -> WantedConstraints -> TcM ()+report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted+  | isEmptyWC wanted+  = return ()++  | otherwise  -- NB: we build an implication /even if skol_tvs is empty/,+               -- just to ensure that our level invariants hold, specifically+               -- (WantedInv).  See Note [TcLevel invariants].+  = checkNoErrs $   -- Fail+    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted+       ; reportAllUnsolved (mkImplicWC (unitBag implic)) }+++-- | Simplify top-level constraints, but without reporting any unsolved+-- constraints nor unsafe overlapping.+simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints+simplifyTopWanteds wanteds+  = do { -- Solve the constraints+         wc_first_go <- nestTcS (solveWanteds wanteds)++         -- Now try defaulting:+         -- see Note [Top-level Defaulting Plan]+       ; tryDefaulting wc_first_go }++{- Note [Safe Haskell Overlapping Instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Safe Haskell, we apply an extra restriction to overlapping instances. The+motive is to prevent untrusted code provided by a third-party, changing the+behavior of trusted code through type-classes. This is due to the global and+implicit nature of type-classes that can hide the source of the dictionary.++Another way to state this is: if a module M compiles without importing another+module N, changing M to import N shouldn't change the behavior of M.++Overlapping instances with type-classes can violate this principle. However,+overlapping instances aren't always unsafe. They are just unsafe when the most+selected dictionary comes from untrusted code (code compiled with -XSafe) and+overlaps instances provided by other modules.++In particular, in Safe Haskell at a call site with overlapping instances, we+apply the following rule to determine if it is a 'unsafe' overlap:++ 1) Most specific instance, I1, defined in an `-XSafe` compiled module.+ 2) I1 is an orphan instance or a MPTC.+ 3) At least one overlapped instance, Ix, is both:+    A) from a different module than I1+    B) Ix is not marked `OVERLAPPABLE`++This is a slightly involved heuristic, but captures the situation of an+imported module N changing the behavior of existing code. For example, if+condition (2) isn't violated, then the module author M must depend either on a+type-class or type defined in N.++Secondly, when should these heuristics be enforced? We enforced them when the+type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`.+This allows `-XUnsafe` modules to operate without restriction, and for Safe+Haskell inference to infer modules with unsafe overlaps as unsafe.++One alternative design would be to also consider if an instance was imported as+a `safe` import or not and only apply the restriction to instances imported+safely. However, since instances are global and can be imported through more+than one path, this alternative doesn't work.++Note [Safe Haskell Overlapping Instances Implementation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How is this implemented? It's complicated! So we'll step through it all:++ 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where+    we check if a particular type-class method call is safe or unsafe. We do this+    through the return type, `ClsInstLookupResult`, where the last parameter is a+    list of instances that are unsafe to overlap. When the method call is safe,+    the list is null.++ 2) `GHC.Tc.Solver.Dict.matchClassInst` -- This module drives the instance resolution+    / dictionary generation. The return type is `ClsInstResult`, which either+    says no instance matched, or one found, and if it was a safe or unsafe+    overlap.++ 3) `GHC.Tc.Solver.Dict.tryInstances` -- Takes a dictionary / class constraint and+     tries to resolve it by calling (in part) `matchClassInst`. The resolving+     mechanism has a work list (of constraints) that it process one at a time. If+     the constraint can't be resolved, it's added to an inert set. When compiling+     an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know+     compilation should fail. These are handled as normal constraint resolution+     failures from here-on (see step 6).++     Otherwise, we may be inferring safety (or using `-Wunsafe`), and+     compilation should succeed, but print warnings and/or mark the compiled module+     as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds+     the unsafe (but resolved!) constraint to the `inert_safehask` field of+     `InertCans`.++ 4) `GHC.Tc.Solver.simplifyTop`:+       * Call simplifyTopWanteds, the top-level function for driving the simplifier for+         constraint resolution.++       * Once finished, call `getSafeOverlapFailures` to retrieve the+         list of overlapping instances that were successfully resolved,+         but unsafe. Remember, this is only applicable for generating warnings+         (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy`+         cause compilation failure by not resolving the unsafe constraint at all.++       * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`,+         while for resolved but unsafe overlapping dictionary constraints, call+         `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a+         warning message for the user.++       * In the case of `warnAllUnsolved` for resolved, but unsafe+         dictionary constraints, we collect the generated warning+         message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to+         mark the module we are compiling as unsafe, passing the+         warning message along as the reason.++ 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by+    actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we+    know is the constraint that is unresolved or unsafe. For dictionary, all we+    know is that we need a dictionary of type C, but not what instances are+    available and how they overlap. So we once again call `lookupInstEnv` to+    figure that out so we can generate a helpful error message.++ 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in+      IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`.++ 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling+    `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference+    failed.+-}++------------------+simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()+simplifyAmbiguityCheck ty wc+  = do { traceTc "simplifyAmbiguityCheck {" $+         text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wc++       ; (final_wc, _) <- runTcS $ do { wc1 <- solveWanteds wc+                                      ; tryDefaultingForAmbiguityCheck wc1 }++       ; discardResult (reportUnsolved final_wc)++       ; traceTc "End simplifyAmbiguityCheck }" empty }++------------------+simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)+simplifyInteractive wanteds+  = traceTc "simplifyInteractive" empty >>+    simplifyTop wanteds++------------------+{- Note [Pattern match warnings with insoluble Givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A pattern match on a GADT can introduce new type-level information, which needs+to be analysed in order to get the expected pattern match warnings.++For example:++> type IsBool :: Type -> Constraint+> type family IsBool a where+>   IsBool Bool = ()+>   IsBool b    = b ~ Bool+>+> data T a where+>   MkTInt  :: Int -> T Int+>   MkTBool :: IsBool b => b -> T b+>+> f :: T Int -> Int+> f (MkTInt i) = i++The pattern matching performed by `f` is complete: we can't ever call+`f (MkTBool b)`, as type-checking that application would require producing+evidence for `Int ~ Bool`, which can't be done.++The pattern match checker uses `tcCheckGivens` to accumulate all the Given+constraints, and relies on `tcCheckGivens` to return Nothing if the+Givens become insoluble.   `tcCheckGivens` in turn relies on `insolubleCt`+to identify these insoluble constraints.  So the precise definition of+`insolubleCt` has a big effect on pattern match overlap warnings.++To detect this situation, we check whether there are any insoluble Given+constraints. In the example above, the insoluble constraint was an+equality constraint, but it is also important to detect custom type errors:++> type NotInt :: Type -> Constraint+> type family NotInt a where+>   NotInt Int = TypeError (Text "That's Int, silly.")+>   NotInt _   = ()+>+> data R a where+>   MkT1 :: a -> R a+>   MkT2 :: NotInt a => R a+>+> foo :: R Int -> Int+> foo (MkT1 x) = x++To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble+because it is a custom type error.+Failing to do so proved quite inconvenient for users, as evidence by the+tickets #11503 #14141 #16377 #20180.+Test cases: T11503, T14141.++Examples of constraints that tcCheckGivens considers insoluble:+  - Int ~ Bool,+  - Coercible Float Word,+  - TypeError msg.++Non-examples:+  - constraints which we know aren't satisfied,+    e.g. Show (Int -> Int) when no such instance is in scope,+  - Eq (TypeError msg),+  - C (Int ~ Bool), with @class C (c :: Constraint)@.+-}++tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet)+-- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely+-- contradictory.+--+-- See Note [Pattern match warnings with insoluble Givens] above.+tcCheckGivens inerts given_ids = do+  (sat, new_inerts) <- runTcSInerts inerts $ do+    traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids)+    lcl_env <- TcS.getLclEnv+    let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)+    let given_cts = mkGivens given_loc (bagToList given_ids)+    -- See Note [Superclasses and satisfiability]+    solveSimpleGivens given_cts+    insols <- getInertInsols+    insols <- try_harder insols+    traceTcS "checkGivens }" (ppr insols)+    return (isEmptyBag insols)+  return $ if sat then Just new_inerts else Nothing+  where+    try_harder :: Cts -> TcS Cts+    -- Maybe we have to search up the superclass chain to find+    -- an unsatisfiable constraint.  Example: pmcheck/T3927b.+    -- At the moment we try just once+    try_harder insols+      | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable+      = return insols             -- Hurrah -- stop now.+      | otherwise+      = do { pending_given <- getPendingGivenScs+           ; new_given <- makeSuperClasses pending_given+           ; solveSimpleGivens new_given+           ; getInertInsols }++tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool+-- ^ Return True if the Wanteds are soluble, False if not+tcCheckWanteds inerts wanteds = do+  cts <- newWanteds PatCheckOrigin wanteds+  (sat, _new_inerts) <- runTcSInerts inerts $ do+    traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds)+    -- See Note [Superclasses and satisfiability]+    wcs <- solveWanteds (mkSimpleWC cts)+    traceTcS "checkWanteds }" (ppr wcs)+    return (isSolvedWC wcs)+  return sat++-- | Normalise a type as much as possible using the given constraints.+-- See @Note [tcNormalise]@.+tcNormalise :: InertSet -> Type -> TcM Type+tcNormalise inerts ty+  = do { norm_loc <- getCtLocM PatCheckOrigin Nothing+       ; (res, _new_inerts) <- runTcSInerts inerts $+             do { traceTcS "tcNormalise {" (ppr inerts)+                ; ty' <- rewriteType norm_loc ty+                ; traceTcS "tcNormalise }" (ppr ty')+                ; pure ty' }+       ; return res }++{- Note [Superclasses and satisfiability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Expand superclasses before starting, because (Int ~ Bool), has+(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool)+as a superclass, and it's the latter that is insoluble.  See+Note [The equality types story] in GHC.Builtin.Types.Prim.++If we fail to prove unsatisfiability we (arbitrarily) try just once to+find superclasses, using try_harder.  Reason: we might have a type+signature+   f :: F op (Implements push) => ..+where F is a type function.  This happened in #3972.++We could do more than once but we'd have to have /some/ limit: in the+the recursive case, we would go on forever in the common case where+the constraints /are/ satisfiable (#10592 comment:12!).++For straightforward situations without type functions the try_harder+step does nothing.++Note [tcNormalise]+~~~~~~~~~~~~~~~~~~+tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas+most invocations of the constraint solver are intended to simplify a set of+constraints or to decide if a particular set of constraints is satisfiable,+the purpose of tcNormalise is to take a type, plus some locally solved+constraints in the form of an InertSet, and normalise the type as much as+possible with respect to those constraints.++It does *not* reduce type or data family applications or look through newtypes.++Why is this useful? As one example, when coverage-checking an EmptyCase+expression, it's possible that the type of the scrutinee will only reduce+if some local equalities are solved for. See "Wrinkle: Local equalities"+in Note [Type normalisation] in "GHC.HsToCore.Pmc".++To accomplish its stated goal, tcNormalise first initialises the solver monad+with the given InertCans, then uses rewriteType to simplify the desired type+with respect to the Givens in the InertCans.++***********************************************************************************+*                                                                                 *+*                            Inference+*                                                                                 *+***********************************************************************************++Note [Inferring the type of a let-bound variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = rhs++To infer f's type we do the following:+ * Gather the constraints for the RHS with ambient level *one more than*+   the current one.  This is done by the call+        pushLevelAndCaptureConstraints (tcMonoBinds...)+   in GHC.Tc.Gen.Bind.tcPolyInfer++ * Call simplifyInfer to simplify the constraints and decide what to+   quantify over. We pass in the level used for the RHS constraints,+   here called rhs_tclvl.++This ensures that the implication constraint we generate, if any,+has a strictly-increased level compared to the ambient level outside+the let binding.++Note [Inferring principal types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't always infer principal types. For instance, the inferred type for++> f x = show [x]++is++> f :: Show a => a -> String++This is not the most general type if we allow flexible contexts.+Indeed, if we try to write the following++> g :: Show [a] => a -> String+> g x = f x++we get the error:++  * Could not deduce (Show a) arising from a use of `f'+    from the context: Show [a]++Though replacing f x in the right-hand side of g with the definition+of f x works, the call to f x does not. This is the hallmark of+unprincip{led,al} types.++Another example:++> class C a+> class D a where+>   d :: a+> instance C a => D a where+>   d = undefined+> h _ = d   -- argument is to avoid the monomorphism restriction++The inferred type for h is++> h :: C a => t -> a++even though++> h :: D a => t -> a++is more general.++The fix is easy: don't simplify constraints before inferring a type.+That is, have the inferred type quantify over all constraints that arise+in a definition's right-hand side, even if they are simplifiable.+Unfortunately, this would yield all manner of unwieldy types,+and so we won't do so.+-}++-- | How should we choose which constraints to quantify over?+data InferMode = ApplyMR          -- ^ Apply the monomorphism restriction,+                                  -- never quantifying over any constraints+               | EagerDefaulting  -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module",+                                  -- the :type +d case; this mode refuses+                                  -- to quantify over any defaultable constraint+               | NoRestrictions   -- ^ Quantify over any constraint that+                                  -- satisfies pickQuantifiablePreds++instance Outputable InferMode where+  ppr ApplyMR         = text "ApplyMR"+  ppr EagerDefaulting = text "EagerDefaulting"+  ppr NoRestrictions  = text "NoRestrictions"++simplifyInfer :: TopLevelFlag+              -> TcLevel               -- Used when generating the constraints+              -> InferMode+              -> [TcIdSigInst]         -- Any signatures (possibly partial)+              -> [(Name, TcTauType)]   -- Variables to be generalised,+                                       -- and their tau-types+              -> WantedConstraints+              -> TcM ([TcTyVar],    -- Quantify over these type variables+                      [EvVar],      -- ... and these constraints (fully zonked)+                      TcEvBinds,    -- ... binding these evidence variables+                      Bool)         -- True <=> the residual constraints are insoluble++simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds+  | isEmptyWC wanteds+   = do { -- When quantifying, we want to preserve any order of variables as they+          -- appear in partial signatures. cf. decideQuantifiedTyVars+          let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs+                                           , (_,Bndr tv _) <- sig_inst_skols sig ]+              psig_theta  = [ pred | sig <- partial_sigs+                                   , pred <- sig_inst_theta sig ]++       ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)++       ; skol_info <- mkSkolemInfo (InferSkol name_taus)+       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars+       ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)+       ; return (qtkvs, [], emptyTcEvBinds, False) }++  | otherwise+  = do { traceTc "simplifyInfer {"  $ vcat+             [ text "sigs =" <+> ppr sigs+             , text "binds =" <+> ppr name_taus+             , text "rhs_tclvl =" <+> ppr rhs_tclvl+             , text "infer_mode =" <+> ppr infer_mode+             , text "(unzonked) wanted =" <+> ppr wanteds+             ]++       ; let psig_theta = concatMap sig_inst_theta partial_sigs++       -- First do full-blown solving+       -- NB: we must gather up all the bindings from doing this solving; hence+       -- (runTcSWithEvBinds ev_binds_var).  And note that since there are+       -- nested implications, calling solveWanteds will side-effect their+       -- evidence bindings, so we can't just revert to the input constraint.+       --+       -- See also Note [Inferring principal types]+       ; ev_binds_var <- TcM.newTcEvBinds+       ; psig_evs     <- newWanteds AnnOrigin psig_theta+       ; wanted_transformed+            <- runTcSWithEvBinds ev_binds_var $+               setTcLevelTcS rhs_tclvl        $+               solveWanteds (mkSimpleWC psig_evs `andWC` wanteds)+               -- setLevelTcS: we do setLevel /inside/ the runTcS, so that+               --              we initialise the InertSet inert_given_eq_lvl as far+               --              out as possible, maximising oppportunities to unify+               -- psig_evs : see Note [Add signature contexts as wanteds]++       -- Find quant_pred_candidates, the predicates that+       -- we'll consider quantifying over+       -- NB1: wanted_transformed does not include anything provable from+       --      the psig_theta; it's just the extra bit+       -- NB2: We do not do any defaulting when inferring a type, this can lead+       --      to less polymorphic types, see Note [Default while Inferring]+       ; wanted_transformed <- TcM.liftZonkM $ TcM.zonkWC wanted_transformed+       ; let definite_error = insolubleWC wanted_transformed+                              -- See Note [Quantification with errors]+             wanted_dq | definite_error = emptyWC+                       | otherwise      = wanted_transformed++       -- Decide what type variables and constraints to quantify+       -- NB: quant_pred_candidates is already fully zonked+       -- NB: bound_theta are constraints we want to quantify over,+       --     including the psig_theta, which we always quantify over+       -- NB: bound_theta are fully zonked+       -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]+       --           in GHC.Tc.Utils.TcType+       ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification+                                                     top_lvl rhs_tclvl infer_mode+                                                     skol_info name_taus partial_sigs+                                                     wanted_dq++             ; bound_theta_vars <- mapM TcM.newEvVar bound_theta++             ; let full_theta = map idType bound_theta_vars+                   skol_info  = InferSkol [ (name, mkPhiTy full_theta ty)+                                          | (name, ty) <- name_taus ]+                 -- mkPhiTy: we don't add the quantified variables here, because+                 -- they are also bound in ic_skols and we want them to be tidied+                 -- uniformly.+       }+++       -- Now emit the residual constraint+       ; emitResidualConstraints rhs_tclvl skol_info ev_binds_var+                                 co_vars qtvs bound_theta_vars+                                 wanted_transformed++         -- All done!+       ; traceTc "} simplifyInfer/produced residual implication for quantification" $+         vcat [ text "wanted_dq ="      <+> ppr wanted_dq+              , text "psig_theta ="     <+> ppr psig_theta+              , text "bound_theta ="    <+> pprCoreBinders bound_theta_vars+              , text "qtvs ="           <+> ppr qtvs+              , text "definite_error =" <+> ppr definite_error ]++       ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) }+         -- NB: bound_theta_vars must be fully zonked+  where+    partial_sigs = filter isPartialSig sigs++--------------------+emitResidualConstraints :: TcLevel -> SkolemInfoAnon -> EvBindsVar+                        -> CoVarSet -> [TcTyVar] -> [EvVar]+                        -> WantedConstraints -> TcM ()+-- Emit the remaining constraints from the RHS.+emitResidualConstraints rhs_tclvl skol_info ev_binds_var+                        co_vars qtvs full_theta_vars wanteds+  | isEmptyWC wanteds+  = return ()++  | otherwise+  = do { wanted_simple <- TcM.liftZonkM $ TcM.zonkSimples (wc_simple wanteds)+       ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple+             is_mono ct+               | Just ct_ev_id <- wantedEvId_maybe ct+               = ct_ev_id `elemVarSet` co_vars+               | otherwise+               = False+             -- Reason for the partition:+             -- see Note [Emitting the residual implication in simplifyInfer]++-- Already done by defaultTyVarsAndSimplify+--      ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple)++        ; let inner_wanted = wanteds { wc_simple = inner_simple }+        ; implics <- if isEmptyWC inner_wanted+                     then return emptyBag+                     else do implic1 <- newImplication+                             return $ unitBag $+                                      implic1  { ic_tclvl     = rhs_tclvl+                                               , ic_skols     = qtvs+                                               , ic_given     = full_theta_vars+                                               , ic_wanted    = inner_wanted+                                               , ic_binds     = ev_binds_var+                                               , ic_given_eqs = MaybeGivenEqs+                                               , ic_info      = skol_info }++        ; emitConstraints (emptyWC { wc_simple = outer_simple+                                   , wc_impl   = implics }) }++--------------------+findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType+-- Given a partial type signature f :: (C a, D a, _) => blah+-- and the inferred constraints (X a, D a, Y a, C a)+-- compute the difference, which is what will fill in the "_" underscore,+-- In this case the diff is (X a, Y a).+findInferredDiff annotated_theta inferred_theta+  | null annotated_theta   -- Short cut the common case when the user didn't+  = return inferred_theta  -- write any constraints in the partial signature+  | otherwise+  = pushTcLevelM_ $+    do { lcl_env   <- TcM.getLclEnv+       ; given_ids <- mapM TcM.newEvVar annotated_theta+       ; wanteds   <- newWanteds AnnOrigin inferred_theta+       ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)+             given_cts = mkGivens given_loc given_ids++       ; (residual_wc, _) <- runTcS $+                             do { _ <- solveSimpleGivens given_cts+                                ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }+         -- NB: There are no meta tyvars fromn this level annotated_theta+         -- because we have either promoted them or unified them+         -- See `Note [Quantification and partial signatures]` Wrinkle 2++       ; return (map (box_pred . ctPred) $+                 bagToList (wc_simple residual_wc)) }+  where+     box_pred :: PredType -> PredType+     box_pred pred = case classifyPredType pred of+                        EqPred rel ty1 ty2+                          | Just (cls,tys) <- boxEqPred rel ty1 ty2+                          -> mkClassPred cls tys+                          | otherwise+                          -> pprPanic "findInferredDiff" (ppr pred)+                        _other -> pred++{- Note [Emitting the residual implication in simplifyInfer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f = e+where f's type is inferred to be something like (a, Proxy k (Int |> co))+and we have an as-yet-unsolved, or perhaps insoluble, constraint+   [W] co :: Type ~ k+We can't form types like (forall co. blah), so we can't generalise over+the coercion variable, and hence we can't generalise over things free in+its kind, in the case 'k'.  But we can still generalise over 'a'.  So+we'll generalise to+   f :: forall a. (a, Proxy k (Int |> co))+Now we do NOT want to form the residual implication constraint+   forall a. [W] co :: Type ~ k+because then co's eventual binding (which will be a value binding if we+use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose+type mentions 'co').  Instead, just as we don't generalise over 'co', we+should not bury its constraint inside the implication.  Instead, we must+put it outside.++That is the reason for the partitionBag in emitResidualConstraints,+which takes the CoVars free in the inferred type, and pulls their+constraints out.  (NB: this set of CoVars should be closed-over-kinds.)++All rather subtle; see #14584.++Note [Add signature contexts as wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#11016):+  f2 :: (?x :: Int) => _+  f2 = ?x++or this+  class C a b | a -> b+  g :: C p q => p -> q+  f3 :: C Int b => _+  f3 = g (3::Int)++We'll use plan InferGen because there are holes in the type.  But:+ * For f2 we want to have the (?x :: Int) constraint floating around+   so that the functional dependencies kick in.  Otherwise the+   occurrence of ?x on the RHS produces constraint (?x :: alpha), and+   we won't unify alpha:=Int.++ * For f3 want the (C Int b) constraint from the partial signature+   to meet the (C Int beta) constraint we get from the call to g; again,+   fundeps++Solution: in simplifyInfer, we add the constraints from the signature+as extra Wanteds.++Why Wanteds?  Wouldn't it be neater to treat them as Givens?  Alas+that would mess up (GivenInv) in Note [TcLevel invariants].  Consider+    f :: (Eq a, _) => blah1+    f = ....g...+    g :: (Eq b, _) => blah2+    g = ...f...++Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with+TyVarTvs inside.  Ultimately a[tv] := b[tv], but only when we've solved+all those constraints.  And both have level 1, so we can't put them as+Givens when solving at level 1.++Best to treat them as Wanteds.++But see also #20076, which would be solved if they were Givens.+++************************************************************************+*                                                                      *+                Quantification+*                                                                      *+************************************************************************++Note [Deciding quantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the monomorphism restriction does not apply, then we quantify as follows:++* Step 1: decidePromotedTyVars.+  Take the global tyvars, and "grow" them using functional dependencies+     E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can+          happen because alpha is untouchable here) then do not quantify over+          beta, because alpha fixes beta, and beta is effectively free in+          the environment too; this logic extends to general fundeps, not+          just equalities++  We also account for the monomorphism restriction; if it applies,+  add the free vars of all the constraints.++  Result is mono_tvs; we will promote all of these to the outer levek,+  and certainly not quantify over them.++* Step 2: defaultTyVarsAndSimplify.+  Default any non-promoted tyvars (i.e ones that are definitely+  not going to become further constrained), and re-simplify the+  candidate constraints.++  Motivation for re-simplification (#7857): imagine we have a+  constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are+  not free in the envt, and instance forall (a::*) (b::*). (C a) => C+  (a -> b) The instance doesn't match while l1,l2 are polymorphic, but+  it will match when we default them to LiftedRep.++  This is all very tiresome.++  This step also promotes the mono_tvs from Step 1. See+  Note [Promote monomorphic tyvars]. In fact, the *only*+  use of the mono_tvs from Step 1 is to promote them here.+  This promotion effectively stops us from quantifying over them+  later, in Step 3. Because the actual variables to quantify+  over are determined in Step 3 (not in Step 1), it is OK for+  the mono_tvs to be missing some variables free in the+  environment. This is why removing the psig_qtvs is OK in+  decidePromotedTyVars. Test case for this scenario: T14479.++* Step 3: decideQuantifiedTyVars.+  Decide which variables to quantify over, as follows:++  - Take the free vars of the partial-type-signature types and constraints,+    and the tau-type (zonked_tau_tvs), and then "grow"+    them using all the constraints.  These are grown_tcvs.+    See Note [growThetaTyVars vs closeWrtFunDeps].++  - Use quantifyTyVars to quantify over the free variables of all the types+    involved, but only those in the grown_tcvs.++  Result is qtvs.++* Step 4: Filter the constraints using pickQuantifiablePreds and the+  qtvs. We have to zonk the constraints first, so they "see" the+  freshly created skolems.++Note [Unconditionally resimplify constraints when quantifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke+the solver to simplify the constraints before quantifying them. We do this for+two reasons, enumerated below. We could, in theory, detect when either of these+cases apply and simplify only then, but collecting this information is bothersome,+and simplifying redundantly causes no real harm. Note that this code path+happens only for definitions+  * without a type signature+  * when -XMonoLocalBinds does not apply+  * with unsolved constraints+and so the performance cost will be small.++1. Defaulting++Defaulting the variables handled by defaultTyVar may unlock instance simplifications.+Example (typecheck/should_compile/T20584b):++  with (t :: Double) (u :: String) = printf "..." t u++We know the types of t and u, but we do not know the return type of `with`. So, we+assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is+  printf :: PrintfType r => String -> r+The occurrence of printf is instantiated with a fresh var beta. We then get+  beta := Double -> String -> alpha+and+  [W] PrintfType (Double -> String -> alpha)++Module Text.Printf exports+  instance (PrintfArg a, PrintfType r) => PrintfType (a -> r)+and it looks like that instance should apply.++But I have elided some key details: (->) is polymorphic over multiplicity and+runtime representation. Here it is in full glory:+  [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho))+  instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type))++Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance+would have an explicit equality constraint to the left of =>, but that's not what we have.)+Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep.+Yet it's too late to simplify the quantified constraint, and thus GHC infers+  wait :: PrintfType (Double -> String -> t) => Double -> String -> t+which is silly. Simplifying again after defaulting solves this problem.++2. Interacting functional dependencies++Suppose we have++  class C a b | a -> b++and we are running simplifyInfer over++  forall[2] x. () => [W] C a beta1[1]+  forall[2] y. () => [W] C a beta2[1]++These are two implication constraints, both of which contain a+wanted for the class C. Neither constraint mentions the bound+skolem. We might imagine that these constraints could thus float+out of their implications and then interact, causing beta1 to unify+with beta2, but constraints do not currently float out of implications.++Unifying the beta1 and beta2 is important. Without doing so, then we might+infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the+ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as+required by the fundep interactions. This happens in the parsec library, and+in test case typecheck/should_compile/FloatFDs.++If we re-simplify, however, the two fundep constraints will interact, causing+a unification between beta1 and beta2, and all will be well. The key step+is that this simplification happens *after* the call to approximateWC in+simplifyInfer.++-}++decideQuantification+  :: TopLevelFlag+  -> TcLevel+  -> InferMode+  -> SkolemInfoAnon+  -> [(Name, TcTauType)]   -- Variables to be generalised+  -> [TcIdSigInst]         -- Partial type signatures (if any)+  -> WantedConstraints     -- Candidate theta; already zonked+  -> TcM ( [TcTyVar]       -- Quantify over these (skolems)+         , [PredType]      -- and this context (fully zonked)+         , CoVarSet)+-- See Note [Deciding quantification]+decideQuantification top_lvl rhs_tclvl infer_mode skol_info name_taus psigs wanted+  = do { -- Step 1: find the mono_tvs+       ; (candidates, co_vars)+             <- decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted++       -- Step 2: default any non-mono tyvars, and re-simplify+       -- This step may do some unification, but result candidates is zonked+       ; candidates <- defaultTyVarsAndSimplify rhs_tclvl candidates++       -- Step 3: decide which kind/type variables to quantify over+       ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates++       -- Step 4: choose which of the remaining candidate+       --         predicates to actually quantify over+       -- NB: decideQuantifiedTyVars turned some meta tyvars+       -- into quantified skolems, so we have to zonk again+       ; (candidates, psig_theta) <- TcM.liftZonkM $+          do { candidates <- TcM.zonkTcTypes candidates+             ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)+             ; return (candidates, psig_theta) }++       -- Take account of partial type signatures+       -- See Note [Constraints in partial type signatures]+       ; let min_psig_theta = mkMinimalBySCs id psig_theta+             min_theta      = pickQuantifiablePreds (mkVarSet qtvs) candidates+       ; theta <- if+           | null psigs -> return min_theta                 -- Case (P3)+           | not (all has_extra_constraints_wildcard psigs) -- Case (P2)+             -> return min_psig_theta+           | otherwise                                      -- Case (P1)+             -> do { diff <- findInferredDiff min_psig_theta min_theta+                   ; return (min_psig_theta ++ diff) }++       ; traceTc "decideQuantification"+           (vcat [ text "infer_mode:" <+> ppr infer_mode+                 , text "candidates:" <+> ppr candidates+                 , text "psig_theta:" <+> ppr psig_theta+                 , text "co_vars:"    <+> ppr co_vars+                 , text "qtvs:"       <+> ppr qtvs+                 , text "theta:"      <+> ppr theta ])+       ; return (qtvs, theta, co_vars) }++  where+    has_extra_constraints_wildcard (TISI { sig_inst_wcx = Just {} }) = True+    has_extra_constraints_wildcard _                                 = False++{- Note [Constraints in partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have decided to quantify over min_theta, say (Eq a, C a, Ix a).+Then we distinguish three cases:++(P1) No partial type signatures: just quantify over min_theta++(P2) Partial type signatures with no extra_constraints wildcard:+      e.g.   f :: (Eq a, C a) => a -> _+     Quantify over psig_theta: the user has explicitly specified the+     entire context.++     That may mean we have an unsolved residual constraint (Ix a) arising+     from the RHS of the function. But so be it: the user said (Eq a, C a).++(P3) Partial type signature with an extra_constraints wildcard.+      e.g.   f :: (Eq a, C a, _) => a -> a+    Quantify over (psig_theta ++ diff)+      where diff = min_theta - psig_theta, using findInferredDiff.+    In our example, diff = Ix a++Some rationale and observations++* See Note [When the MR applies] in GHC.Tc.Gen.Bind.++* We always want to quantify over psig_theta (if present).  The user specified+  it!  And pickQuantifiableCandidates might have dropped some+  e.g. CallStack constraints.  c.f #14658+       equalities (a ~ Bool)++* In case (P3) we ask that /all/ the signatures have an extra-constraints+  wildcard.  It's a bit arbitrary; not clear what the "right" thing is.++* In (P2) we encounter #20076:+     f :: Eq [a] => a -> _+     f x = [x] == [x]+  From the RHS we get [W] Eq [a].  We simplify those Wanteds in simplifyInfer,+  to get (Eq a).  But then we quantify over the user-specified (Eq [a]), leaving+  a residual implication constraint (forall a. Eq [a] => [W] Eq a), which is+  insoluble.  Idea: in simplifyInfer we could put the /un-simplified/ constraints+  in the residual -- at least in the case like #20076 where the partial signature+  fully specifies the final constraint. Maybe: a battle for another day.++* It's helpful to use the same "find difference" algorithm, `findInferredDiff`,+  here as we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921)++  At least for single functions we would like to quantify f over precisely the+  same theta as <quant-theta>, so that we get to take the short-cut path in+  `GHC.Tc.Gen.Bind.mkExport`, and avoid calling `tcSubTypeSigma` for impedance+  matching. Why avoid?  Because it falls over for ambiguous types (#20921).++  We can get precisely the same theta by using the same algorithm,+  `findInferredDiff`.++* All of this goes wrong if we have (a) mutual recursion, (b) multiple+  partial type signatures, (c) with different constraints, and (d)+  ambiguous types.  Something like+    f :: forall a. Eq a => F a -> _+    f x = (undefined :: a) == g x undefined+    g :: forall b. Show b => F b -> _ -> b+    g x y = let _ = (f y, show x) in x+  But that's a battle for another day.++Note [Generalising top-level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  class C a b | a -> b where ..+  f x = ...[W] C Int beta[1]...++When generalising `f`, closeWrtFunDeps will promote beta[1] to beta[0].+But we do NOT want to make a top level type+  f :: C Int beta[0] => blah+The danger is that beta[0] is defaulted to Any, and that then appears+in a user error message.  Even if the type `blah` mentions beta[0], /and/+there is a call that fixes beta[0] to (say) Bool, we'll end up with+[W] C Int Bool, which is insoluble.  Why insoluble? If there was an+   instance C Int Bool+then fundeps would have fixed beta:=Bool in the first place.++If the binding of `f` is nested, things are different: we can+definitely see all the calls.++For nested bindings, I think it just doesn't matter. No one cares what this+variable ends up being; it seems silly to halt compilation around it. (Like in+the length [] case.)+-}++decideAndPromoteTyVars :: TopLevelFlag -> TcLevel+                       -> InferMode+                       -> [(Name,TcType)]+                       -> [TcIdSigInst]+                       -> WantedConstraints+                       -> TcM ([PredType], CoVarSet)+-- See Note [decideAndPromoteTyVars]+decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted+  = do { dflags <- getDynFlags++       -- If possible, we quantify over partial-sig qtvs, so they are+       -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs+       ; (psig_qtvs, psig_theta, tau_tys) <- getSeedTys name_taus psigs++       ; let is_top_level = isTopLevel top_lvl  -- A syntactically top-level binding++             -- Step 1 of Note [decideAndPromoteTyVars]+             -- Get candidate constraints, decide which we can potentially quantify+             -- The `no_quant_tvs` are free in constraints we can't quantify.+             (can_quant_cts, no_quant_tvs) = approximateWCX False wanted+             can_quant = ctsPreds can_quant_cts+             can_quant_tvs = tyCoVarsOfTypes can_quant++             -- Step 2 of Note [decideAndPromoteTyVars]+             -- Apply the monomorphism restriction+             (post_mr_quant, mr_no_quant) = applyMR dflags infer_mode can_quant+             mr_no_quant_tvs              = tyCoVarsOfTypes mr_no_quant++             -- The co_var_tvs are tvs mentioned in the types of covars or+             -- coercion holes. We can't quantify over these covars, so we+             -- must include the variable in their types in the mono_tvs.+             -- E.g.  If we can't quantify over co :: k~Type, then we can't+             --       quantify over k either!  Hence closeOverKinds+             -- Recall that coVarsOfTypes also returns coercion holes+             co_vars    = coVarsOfTypes (mkTyVarTys psig_qtvs ++ psig_theta+                                         ++ tau_tys ++ post_mr_quant)+             co_var_tvs = closeOverKinds co_vars++             -- outer_tvs are mentioned in `wanted`, and belong to some outer level.+             -- We definitely can't quantify over them+             outer_tvs = outerLevelTyVars rhs_tclvl $+                         can_quant_tvs `unionVarSet` no_quant_tvs++             -- Step 3 of Note [decideAndPromoteTyVars], (a-c)+             -- Identify mono_tvs: the type variables that we must not quantify over+             -- At top level we are much less keen to create mono tyvars, to avoid+             -- spooky action at a distance.+             mono_tvs_without_mr+               | is_top_level = outer_tvs    -- See (DP2)+               | otherwise    = outer_tvs                    -- (a)+                                `unionVarSet` no_quant_tvs   -- (b)+                                `unionVarSet` co_var_tvs     -- (c)++             -- Step 3 of Note [decideAndPromoteTyVars], (d)+             mono_tvs_with_mr+               = -- Even at top level, we don't quantify over type variables+                 -- mentioned in constraints that the MR tells us not to quantify+                 -- See Note [decideAndPromoteTyVars] (DP2)+                 mono_tvs_without_mr `unionVarSet` mr_no_quant_tvs++             --------------------------------------------------------------------+             -- Step 4 of Note [decideAndPromoteTyVars]+             -- Use closeWrtFunDeps to find any other variables that are determined by mono_tvs+             add_determined tvs preds = closeWrtFunDeps preds tvs+                                        `delVarSetList` psig_qtvs+                 -- Why delVarSetList psig_qtvs?+                 -- If the user has explicitly asked for quantification, then that+                 -- request "wins" over the MR.+                 --+                 -- What if a psig variable is also free in the environment+                 -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation+                 -- in Step 2 of Note [Deciding quantification].++             mono_tvs_with_mr_det    = add_determined mono_tvs_with_mr    post_mr_quant+             mono_tvs_without_mr_det = add_determined mono_tvs_without_mr can_quant++             --------------------------------------------------------------------+             -- Step 5 of Note [decideAndPromoteTyVars]+             -- Do not quantify over any constraint mentioning a "newly-mono" tyvar.+             newly_mono_tvs = mono_tvs_with_mr_det `minusVarSet` mono_tvs_with_mr+             final_quant+               | is_top_level = filterOut (predMentions newly_mono_tvs) post_mr_quant+               | otherwise    = post_mr_quant++       --------------------------------------------------------------------+       -- Check if the Monomorphism Restriction has bitten+       ; warn_mr <- woptM Opt_WarnMonomorphism+       ; when (warn_mr && case infer_mode of { ApplyMR -> True; _ -> False}) $+         diagnosticTc (not (mono_tvs_with_mr_det `subVarSet` mono_tvs_without_mr_det)) $+              TcRnMonomorphicBindings (map fst name_taus)+             -- If there is a variable in mono_tvs, but not in mono_tvs_wo_mr+             -- then the MR has "bitten" and reduced polymorphism.++       --------------------------------------------------------------------+       -- Step 6: Promote the mono_tvs: see Note [Promote monomorphic tyvars]+       ; _ <- promoteTyVarSet mono_tvs_with_mr_det++       ; traceTc "decideAndPromoteTyVars" $ vcat+           [ text "rhs_tclvl =" <+> ppr rhs_tclvl+           , text "top =" <+> ppr is_top_level+           , text "infer_mode =" <+> ppr infer_mode+           , text "psigs =" <+> ppr psigs+           , text "psig_qtvs =" <+> ppr psig_qtvs+           , text "outer_tvs =" <+> ppr outer_tvs+           , text "mono_tvs_with_mr =" <+> ppr mono_tvs_with_mr+           , text "mono_tvs_without_mr =" <+> ppr mono_tvs_without_mr+           , text "mono_tvs_with_mr_det =" <+> ppr mono_tvs_with_mr_det+           , text "mono_tvs_without_mr_det =" <+> ppr mono_tvs_without_mr_det+           , text "newly_mono_tvs =" <+> ppr newly_mono_tvs+           , text "can_quant =" <+> ppr can_quant+           , text "post_mr_quant =" <+> ppr post_mr_quant+           , text "no_quant_tvs =" <+> ppr no_quant_tvs+           , text "mr_no_quant =" <+> ppr mr_no_quant+           , text "final_quant =" <+> ppr final_quant+           , text "co_vars =" <+> ppr co_vars ]++       ; return (final_quant, co_vars) }+          -- We return `co_vars` that appear free in the final quantified types+          -- we can't quantify over these, and we must make sure they are in scope++-------------------+applyMR :: DynFlags -> InferMode -> [PredType]+        -> ( [PredType]   -- Quantify over these+           , [PredType] ) -- But not over these+-- Split the candidates into ones we definitely+-- won't quantify, and ones that we might+applyMR _      NoRestrictions  cand = (cand, [])+applyMR _      ApplyMR         cand = ([], cand)+applyMR dflags EagerDefaulting cand = partition not_int_ct cand+  where+    ovl_strings = xopt LangExt.OverloadedStrings dflags++    -- not_int_ct returns True for a constraint we /can/ quantify+    -- For EagerDefaulting, do not quantify over+    -- over any interactive class constraint+    not_int_ct pred+      = case classifyPredType pred of+           ClassPred cls _ -> not (isInteractiveClass ovl_strings cls)+           _               -> True++-------------------+outerLevelTyVars :: TcLevel -> TcTyVarSet -> TcTyVarSet+-- Find just the tyvars that are bound outside rhs_tc_lvl+outerLevelTyVars rhs_tclvl tvs+  = filterVarSet is_outer_tv tvs+  where+    is_outer_tv tcv+     | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately+     = rhs_tclvl `strictlyDeeperThan` tcTyVarLevel tcv+     | otherwise+     = False++{- Note [decideAndPromoteTyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are about to generalise a let-binding at "outer level" N, where we have+typechecked its RHS at "rhs level" N+1.  Each tyvar must be either+  (P) promoted+  (D) defaulted+  (Q) quantified+The function `decideAndPromoteTyVars` figures out (P), the type variables+mentioned in constraints should definitely not be quantified, and promotes them+to the outer level, namely N.++The plan++* Step 1.  Use `approximateWCX` to extract, from the RHS `WantedConstraints`,+  the PredTypes that we might quantify over; and also those that we can't.+  Example: suppose the `wanted` is this:+     (d1:Eq alpha, forall b. (F b ~ a) => (co:t1 ~ t2), (d:Show alpha))+  Then+     can_quant = [Eq alpha, Show alpha]+     no_quant  = (t1 ~ t2)+  We can't quantify over that (t1~t2) because of the enclosing equality (F b ~ a).++  We also choose never to quantify over some forms of equality constraints.+  Both this and the "given-equality" thing are described in+  Note [Quantifying over equality constraints] in GHC.Tc.Types.Constraint.++* Step 2. Further trim can_quant using the Monomorphism Restriction, yielding the+  further `mr_no_quant` predicates that we won't quantify over; plus `post_mr_quant`,+  which we can in principle quantify.++* Step 3. Identify the type variables we definitely won't quantify, because they are:+  a) From an outer level <=N anyway+  b) Mentioned in a constraint we /can't/ quantify.  See Wrinkle (DP1).+  c) Mentioned in the kind of a CoVar; we can't quantify over a CoVar,+     so we must not quantify over a type variable free in its kind+  d) Mentioned in a constraint that the MR says we should not quantify.++  There is a special case for top-level bindings: see Wrinkle (DP2).++* Step 4.  Close wrt functional dependencies and equalities.Example+  Example+           f x y = ...+              where z = x 3+  The body of z tries to unify the type of x (call it alpha[1]) with+  (beta[2] -> gamma[2]). This unification fails because alpha is untouchable, leaving+       [W] alpha[1] ~ (beta[2] -> gamma[2])+  We don't want to quantify over beta or gamma because they are fixed by alpha,+  which is monomorphic. Actual test case:   typecheck/should_compile/tc213++  Another example. Suppose we have+      class C a b | a -> b+  and a constraint ([W] C alpha beta), if we promote alpha we should promote beta.++  See also Note [growThetaTyVars vs closeWrtFunDeps]++* Step 5. Further restrict the quantifiable constraints `post_mr_quant` to ones+  that do not mention a "newly mono" tyvar. The "newly-mono" tyvars are the ones+  not free in the envt, nor forced to be promoted by the MR; but are determined+  (via fundeps) by them. Example:+           class C a b | a -> b+           [W] C Int beta[1],  tau = beta[1]->Int+  We promote beta[1] to beta[0] since it is determined by fundep, but we do not+  want to generate f :: (C Int beta[0]) => beta[0] -> Int Rather, we generate+  f :: beta[0] -> Int, but leave [W] C Int beta[0] in the residual constraints,+  which will probably cause a type error++  See Note [Do not quantify over constraints that determine a variable]++* Step 6: actually promote the type variables we don't want to quantify.+  We must do this: see Note [Promote monomorphic tyvars].++We also add a warning that signals when the MR "bites".++Wrinkles++(DP1) In step 3, why (b)?  Consider the example given in Step 1.  we can't+  quantify over the constraint (t1~t2).  But if we quantify over the /tyvars/ in+  t1 or t2, we may simply make that constraint insoluble (#25266 was an example).++(DP2) In Step 3, for top-level bindings, we do (a,d), but /not/ (b,c). Reason:+  see Note [The top-level Any principle].  At top level we are very reluctant to+  promote type variables.  But for bindings affected by the MR we have no choice+  but to promote.++  An example is in #26004.+      f w e = case e of+        T1 -> let y = not w in False+        T2 -> True+  When generalising `f` we have a constraint+      forall. (a ~ Bool) => alpha ~ Bool+  where our provisional type for `f` is `f :: T alpha -> blah`.+  In a /nested/ setting, we might simply not-generalise `f`, hoping to learn+  about `alpha` from f's call sites (test T5266b is an example).  But at top+  level, to avoid spooky action at a distance.++Note [The top-level Any principle]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Key principles:+  * we never want to show the programmer a type with `Any` in it.+  * avoid "spooky action at a distance" and silent defaulting++Most /top level/ bindings have a type signature, so none of this arises.  But+where a top-level binding lacks a signature, we don't want to infer a type like+    f :: alpha[0] -> Int+and then subsequently default alpha[0]:=Any.  Exposing `Any` to the user is bad+bad bad.  Better to report an error, which is what may well happen if we+quantify over alpha instead.++Moreover,+ * If (elsewhere in this module) we add a call to `f`, say (f True), then+   `f` will get the type `Bool -> Int`+ * If we add /another/ call, say (f 'x'), we will then get a type error.+ * If we have no calls, the final exported type of `f` may get set by+   defaulting, and might not be principal (#26004).++For /nested/ bindings, a monomorphic type like `f :: alpha[0] -> Int` is fine,+because we can see all the call sites of `f`, and they will probably fix+`alpha`.  In contrast, we can't see all of (or perhaps any of) the calls of+top-level (exported) functions, reducing the worries about "spooky action at a+distance".  This also moves in the direction of `MonoLocalBinds`, which we like.++Note [Do not quantify over constraints that determine a variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (typecheck/should_compile/tc231), where we're trying to infer+the type of a top-level declaration. We have+  class Zork s a b | a -> b+and the candidate constraint at the end of simplifyInfer is+  [W] Zork alpha[1] (Z [Char]) beta[1]+We definitely want to quantify over `alpha` (which is mentioned in the+tau-type).++But we do *not* want to quantify over `beta`: it is determined by the+functional dependency on Zork: note that the second argument to Zork+in the Wanted is a variable-free `Z [Char]`.  Quantifying over it+would be "Henry Ford polymorphism".  (Presumably we don't have an+instance in scope that tells us what `beta` actually is.)  Instead+we promote `beta[1]` to `beta[0]`, in `decidePromotedTyVars`.++The question here: do we want to quantify over the constraint, to+give the type+   forall a. Zork a (Z [Char]) beta[0] => blah+Definitely not: see Note [The top-level Any principle]++What we really want (to catch the Zork example) is this:++   Quantify over the constraint only if all its free variables are+   (a) quantified, or+   (b) appears in the type of something in the environment (mono_tvs0).++To understand (b) consider++  class C a b where { op :: a -> b -> () }++  mr = 3                      -- mr :: alpha+  f1 x = op x mr              -- f1 :: forall b. b -> (), plus [W] C b alpha+  intify = mr + (4 :: Int)++In `f1` should we quantify over that `(C b alpha)`?  Answer: since `alpha` is+free in the type envt, yes we should.  After all, if we'd typechecked `intify`+first, we'd have set `alpha := Int`, and /then/ we'd certainly quantify.  The+delicate Zork situation applies when beta is completely unconstrained (not free+in the environment) -- except by the fundep.  Hence `newly_mono`.++Another way to put it: let's say `alpha` is in `outer_tvs`. It must be that+some variable `x` has `alpha` free in its type. If we are at top-level (and we+are, because nested decls don't go through this path all), then `x` must also+be at top-level. And, by induction, `x` will not have Any in its type when all+is said and done. The induction is well-founded because, if `x` is mutually+recursive with the definition at hand, then their constraints get processed+together (or `x` has a type signature, in which case the type doesn't have+`Any`). So the key thing is that we must not introduce a new top-level+unconstrained variable here.++However this regrettably-subtle reasoning is needed only for /top-level/+declarations.  For /nested/ decls we can see all the calls, so we'll instantiate+that quantifed `Zork a (Z [Char]) beta` constraint at call sites, and either+solve it or not (probably not).  We won't be left with a still-callable function+with Any in its type.  So for nested definitions we don't make this tricky test.++Historical note: we had a different, and more complicated test before, but it+was utterly wrong: #23199.++Note [Promote monomorphic tyvars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Promote any type variables that are free in the environment.  Eg+   f :: forall qtvs. bound_theta => zonked_tau+The free vars of f's type become free in the envt, and hence will show+up whenever 'f' is called.  They may currently at rhs_tclvl, but they+had better be unifiable at the outer_tclvl!  Example: envt mentions+alpha[1]+           tau_ty = beta[2] -> beta[2]+           constraints = alpha ~ [beta]+we don't quantify over beta (since it is fixed by envt)+so we must promote it!  The inferred type is just+  f :: beta -> beta++NB: promoteTyVarSet ignores coercion variables++Note [Defaulting during simplifyInfer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are inferring a type, we simplify the constraint, and then use+approximateWC to produce a list of candidate constraints.  Then we MUST++  a) Promote any meta-tyvars that have been floated out by+     approximateWC, to restore invariant (WantedInv) described in+     Note [TcLevel invariants] in GHC.Tc.Utils.TcType.++  b) Default the kind of any meta-tyvars that are not mentioned in+     in the environment.++To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we+have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it+should!  If we don't solve the constraint, we'll stupidly quantify over+(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over+(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332.+#7641 is a simpler example.++-}++-------------------+defaultTyVarsAndSimplify :: TcLevel+                         -> [PredType]          -- Assumed zonked+                         -> TcM [PredType]      -- Guaranteed zonked+-- Default any tyvar free in the constraints;+-- and re-simplify in case the defaulting allows further simplification+-- See Note [Defaulting during simplifyInfer]+defaultTyVarsAndSimplify rhs_tclvl candidates+  = do {  -- Default any kind/levity vars+       ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}+                <- candidateQTyVarsOfTypes candidates+         -- NB1: decidePromotedTyVars has promoted any type variable fixed by the+         --      type envt, so they won't be chosen by candidateQTyVarsOfTypes+         -- NB2: Defaulting for variables free in tau_tys is done later, by quantifyTyVars+         --      Hence looking only at 'candidates'+         -- NB3: Any covars should already be handled by+         --      the logic in decidePromotedTyVars, which looks at+         --      the constraints generated++       ; poly_kinds  <- xoptM LangExt.PolyKinds+       ; let default_kv | poly_kinds = default_tv+                        | otherwise  = defaultTyVar DefaultKindVars+             default_tv = defaultTyVar (NonStandardDefaulting DefaultNonStandardTyVars)+       ; mapM_ default_kv (dVarSetElems cand_kvs)+       ; mapM_ default_tv (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))++       ; simplify_cand candidates+       }+  where+    -- See Note [Unconditionally resimplify constraints when quantifying]+    simplify_cand [] = return []  -- Fast path+    simplify_cand candidates+      = do { clone_wanteds <- newWanteds DefaultOrigin candidates+           ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $+                                           simplifyWantedsTcM clone_wanteds+              -- Discard evidence; simples is fully zonked++           ; let new_candidates = ctsPreds simples+           ; traceTc "Simplified after defaulting" $+                      vcat [ text "Before:" <+> ppr candidates+                           , text "After:"  <+> ppr new_candidates ]+           ; return new_candidates }++------------------+decideQuantifiedTyVars+   :: SkolemInfoAnon+   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs+   -> [TcIdSigInst]     -- Partial signatures+   -> [PredType]        -- Candidates, zonked+   -> TcM [TyVar]+-- Fix what tyvars we are going to quantify over, and quantify them+decideQuantifiedTyVars skol_info_anon name_taus psigs candidates+  = do {     -- Why psig_tys? We try to quantify over everything free in here+             -- See Note [Quantification and partial signatures]+             --     Wrinkles 2 and 3+         (psig_qtvs, psig_theta, tau_tys) <- getSeedTys name_taus psigs++       ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta+             seed_tvs = tyCoVarsOfTypes (psig_tys ++ tau_tys)++               -- "Grow" those seeds to find ones reachable via 'candidates'+             -- See Note [growThetaTyVars vs closeWrtFunDeps]+             grown_tcvs = growThetaTyVars candidates seed_tvs++       -- Now we have to classify them into kind variables and type variables+       -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars+       --+       -- The psig_tys are first in seed_tys, then candidates, then tau_tvs.+       -- This makes candidateQTyVarsOfTypes produces them in that order, so that the+        -- final qtvs quantifies in the same- order as the partial signatures do (#13524)+       ; dvs <- candidateQTyVarsOfTypes (psig_tys ++ candidates ++ tau_tys)+       ; let dvs_plus = weedOutCandidates (`dVarSetIntersectVarSet` grown_tcvs) dvs++       ; traceTc "decideQuantifiedTyVars" (vcat+           [ text "tau_tys =" <+> ppr tau_tys+           , text "candidates =" <+> ppr candidates+           , text "dvs =" <+> ppr dvs+           , text "tau_tys =" <+> ppr tau_tys+           , text "seed_tvs =" <+> ppr seed_tvs+           , text "grown_tcvs =" <+> ppr grown_tcvs+           , text "dvs =" <+> ppr dvs_plus])++       ; skol_info <- mkSkolemInfo skol_info_anon+       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus }++------------------+getSeedTys :: [(Name,TcType)]    -- The type of each RHS in the group+           -> [TcIdSigInst]      -- Any partial type signatures+           -> TcM ( [TcTyVar]    -- Zonked partial-sig quantified tyvars+                  , ThetaType    -- Zonked partial signature thetas+                  , [TcType] )   -- Zonked tau-tys from the bindings+getSeedTys name_taus psigs+  = TcM.liftZonkM $+    do { psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | TISI{ sig_inst_skols = skols } <- psigs+                                                  , (_, Bndr tv _) <- skols ]+       ; psig_theta  <- mapM TcM.zonkTcType [ pred | TISI{ sig_inst_theta = theta } <- psigs+                                                   , pred <- theta ]+       ; tau_tys     <- mapM (TcM.zonkTcType . snd) name_taus+       ; return ( map getTyVar psig_tv_tys+                , psig_theta+                , tau_tys ) }++------------------+predMentions :: TcTyVarSet -> TcPredType -> Bool+predMentions qtvs pred = tyCoVarsOfType pred `intersectsVarSet` qtvs++-- | When inferring types, should we quantify over a given predicate?+-- See Note [pickQuantifiablePreds]+pickQuantifiablePreds+  :: TyVarSet           -- Quantifying over these+  -> TcThetaType        -- Proposed constraints to quantify+  -> TcThetaType        -- A subset that we can actually quantify+-- This function decides whether a particular constraint should be+-- quantified over, given the type variables that are being quantified+pickQuantifiablePreds qtvs theta+  = mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]+    mapMaybe pick_me theta+  where+    pick_me pred+      = case classifyPredType pred of+          ClassPred cls _+            | isIPClass cls+            -> Just pred -- Pick, say, (?x::Int) whether or not it mentions qtvs+                         -- See Note [Inheriting implicit parameters]++          EqPred eq_rel ty1 ty2+            | predMentions qtvs pred+            , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2+              -- boxEqPred: See Note [Lift equality constraints when quantifying]+            -> Just (mkClassPred cls tys)+            | otherwise+            -> Nothing++          _ | predMentions qtvs pred -> Just pred+            | otherwise              -> Nothing++------------------+growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet+-- See Note [growThetaTyVars vs closeWrtFunDeps]+growThetaTyVars theta tcvs+  | null theta = tcvs+  | otherwise  = transCloVarSet mk_next seed_tcvs+  where+    seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips+    (ips, non_ips) = partition couldBeIPLike theta+                         -- See Note [Inheriting implicit parameters]++    mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones+    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips+    grow_one so_far pred tcvs+       | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs+       | otherwise                           = tcvs+       where+         pred_tcvs = tyCoVarsOfType pred+++{- Note [pickQuantifiablePreds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When pickQuantifiablePreds is called we have decided what type+variables to quantify over, `qtvs`. The only quesion is: which of the+unsolved candidate predicates should we quantify over?  Call them+`picked_theta`.++Note that will leave behind a residual implication+     forall qtvs. picked_theta => unsolved_constraints+For the members of unsolved_constraints that we select for picked_theta+it is easy to solve, by identity.  For the others we just hope that+we can solve them.++So which of the candidates should we pick to quantify over?  It's pretty easy:++* Never pick a constraint that doesn't mention any of the quantified+  variables `qtvs`.  Picking such a constraint essentially moves the solving of+  the constraint from this function definition to call sites.  But because the+  constraint mentions no quantified variables, call sites have no advantage+  over the definition site. Well, not quite: there could be new constraints+  brought into scope by a pattern-match against a constrained (e.g. GADT)+  constructor.  Example++        data T a where { T1 :: T1 Bool; ... }++        f :: forall a. a -> T a -> blah+        f x t = let g y = x&&y    -- This needs a~Bool+              in case t of+                    T1 -> g True+                    ....++  At g's call site we have `a~Bool`, so we /could/ infer+       g :: forall . (a~Bool) => Bool -> Bool  -- qtvs = {}++  This is all very contrived, and probably just postponse type errors to+  the call site.  If that's what you want, write a type signature.++* Implicit parameters is an exception to the "no quantified vars"+  rule (see Note [Inheriting implicit parameters]) so we can't actually+  simply test this case first.++* Finally, we may need to "box" equality predicates: if we want to quantify+  over `a ~# b`, we actually quantify over the boxed version, `a ~ b`.+  See Note [Lift equality constraints when quantifying].++Notice that we do /not/ consult -XFlexibleContexts here.  For example,+we allow `pickQuantifiablePreds` to quantify over a constraint like+`Num [a]`; then if we don't have `-XFlexibleContexts` we'll get an+error from `checkValidType` but (critically) it includes the helpful+suggestion of adding `-XFlexibleContexts`.  See #10608, #10351.++Note [Lift equality constraints when quantifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can't quantify over a constraint (t1 ~# t2) because that isn't a+predicate type; see Note [Types for coercions, predicates, and evidence]+in GHC.Core.Predicate++So we have to 'lift' it to (t1 ~ t2).  Similarly (~R#) must be lifted+to Coercible.++This tiresome lifting is the reason that pick_me (in+pickQuantifiablePreds) returns a Maybe rather than a Bool.++Note [Inheriting implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++        f x = (x::Int) + ?y++where f is *not* a top-level binding.+From the RHS of f we'll get the constraint (?y::Int).+There are two types we might infer for f:++        f :: Int -> Int++(so we get ?y from the context of f's definition), or++        f :: (?y::Int) => Int -> Int++At first you might think the first was better, because then+?y behaves like a free variable of the definition, rather than+having to be passed at each call site.  But of course, the WHOLE+IDEA is that ?y should be passed at each call site (that's what+dynamic binding means) so we'd better infer the second.++BOTTOM LINE: when *inferring types* you must quantify over implicit+parameters, *even if* they don't mention the bound type variables.+Reason: because implicit parameters, uniquely, have local instance+declarations. See pickQuantifiablePreds.++Note [Quantification and partial signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When choosing type variables to quantify, the basic plan is to+quantify over all type variables that are+ * free in the tau_tvs, and+ * not forced to be monomorphic (mono_tvs),+   for example by being free in the environment.++However, in the case of a partial type signature, we are doing inference+*in the presence of a type signature*. For example:+   f :: _ -> a+   f x = ...+or+   g :: (Eq _a) => _b -> _b+In both cases we use plan InferGen, and hence call simplifyInfer.  But+those 'a' variables are skolems (actually TyVarTvs), and we should be+sure to quantify over them.  This leads to several wrinkles:++* Wrinkle 1.  In the case of a type error+     f :: _ -> Maybe a+     f x = True && x+  The inferred type of 'f' is f :: Bool -> Bool, but there's a+  left-over error of form (Maybe a ~ Bool).  The error-reporting+  machine expects to find a binding site for the skolem 'a', so we+  add it to the quantified tyvars.++* Wrinkle 2.  Consider the partial type signature+     f :: (Eq _) => Int -> Int+     f x = x+  In normal cases that makes sense; e.g.+     g :: Eq _a => _a -> _a+     g x = x+  where the signature makes the type less general than it could+  be. But for 'f' we must therefore quantify over the user-annotated+  constraints, to get+     f :: forall a. Eq a => Int -> Int+  (thereby correctly triggering an ambiguity error later).  If we don't+  we'll end up with a strange open type+     f :: Eq alpha => Int -> Int+  which isn't ambiguous but is still very wrong.++  Bottom line: Try to quantify over any variable free in psig_theta,+  just like the tau-part of the type.++* Wrinkle 3 (#13482). Also consider+    f :: forall a. _ => Int -> Int+    f x = if (undefined :: a) == undefined then x else 0+  Here we get an (Eq a) constraint, but it's not mentioned in the+  psig_theta nor the type of 'f'.  But we still want to quantify+  over 'a' even if the monomorphism restriction is on.++* Wrinkle 4 (#14479)+    foo :: Num a => a -> a+    foo xxx = g xxx+      where+        g :: forall b. Num b => _ -> b+        g y = xxx + y++  In the signature for 'g', we cannot quantify over 'b' because it turns out to+  get unified with 'a', which is free in g's environment.  So we carefully+  refrain from bogusly quantifying, in GHC.Tc.Solver.decidePromotedTyVars.  We+  report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers.++Note [growThetaTyVars vs closeWrtFunDeps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with+the same type and similar behavior. This Note outlines the differences+and why we use one or the other.++Both functions take a list of constraints. We will call these the+*candidates*.++closeWrtFunDeps takes a set of "determined" type variables and finds the+closure of that set with respect to the functional dependencies+within the class constraints in the set of candidates. So, if we+have++  class C a b | a -> b+  class D a b   -- no fundep+  candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)}++then closeWrtFunDeps {a} will return the set {a,b,c}.+This is because, if `a` is determined, then `b` and `c` are, too,+by functional dependency. closeWrtFunDeps called with any seed set not including+`a` will just return its argument, as only `a` determines any other+type variable (in this example).++growThetaTyVars operates similarly, but it behaves as if every+constraint has a functional dependency among all its arguments.+So, continuing our example, growThetaTyVars {a} will return+{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of+variables to include all variables that are mentioned in the same+constraint (transitively).++We use closeWrtFunDeps in places where we need to know which variables are+*always* determined by some seed set. This includes+  * when determining the mono-tyvars in decidePromotedTyVars. If `a`+    is going to be monomorphic, we need b and c to be also: they+    are determined by the choice for `a`.+  * when checking instance coverage, in+    GHC.Tc.Instance.FunDeps.checkInstCoverage++On the other hand, we use growThetaTyVars where we need to know+which variables *might* be determined by some seed set. This includes+  * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers+    and decideQuantifiedTyVars+How can `a` determine (say) `d` in the example above without a fundep?+Suppose we have+  instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c)+Now, if `a` turns out to be a list, it really does determine b and c.+The danger in overdoing quantification is the creation of an ambiguous+type signature, but this is conveniently caught in the validity checker.++Note [Quantification with errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we find that the RHS of the definition has some absolutely-insoluble+constraints (including especially "variable not in scope"), we++* Abandon all attempts to find a context to quantify over,+  and instead make the function fully-polymorphic in whatever+  type we have found++* Return a flag from simplifyInfer, indicating that we found an+  insoluble constraint.  This flag is used to suppress the ambiguity+  check for the inferred type, which may well be bogus, and which+  tends to obscure the real error.  This fix feels a bit clunky,+  but I failed to come up with anything better.++Reasons:+    - Avoid downstream errors+    - Do not perform an ambiguity test on a bogus type, which might well+      fail spuriously, thereby obfuscating the original insoluble error.+      #14000 is an example++I tried an alternative approach: simply failM, after emitting the+residual implication constraint; the exception will be caught in+GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type+(forall a. a).  But that didn't work with -fdefer-type-errors, because+the recovery from failM emits no code at all, so there is no function+to run!   But -fdefer-type-errors aspires to produce a runnable program.++Note [Default while Inferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our current plan is that defaulting only happens at simplifyTop and+not simplifyInfer.  This may lead to some insoluble deferred constraints.+Example:++instance D g => C g Int b++constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha+type inferred       = gamma -> gamma++Now, if we try to default (alpha := Int) we will be able to refine the implication to+  (forall b. 0 => C gamma Int b)+which can then be simplified further to+  (forall b. 0 => D gamma)+Finally, we /can/ approximate this implication with (D gamma) and infer the quantified+type:  forall g. D g => g -> g++Instead what will currently happen is that we will get a quantified type+(forall g. g -> g) and an implication:+       forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha++Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an+unsolvable implication:+       forall g. 0 => (forall b. 0 => D g)++The concrete example would be:+       h :: C g a s => g -> a -> ST s a+       f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)++But it is quite tedious to do defaulting and resolve the implication constraints, and+we have not observed code breaking because of the lack of defaulting in inference, so+we don't do it for now.++Note [Minimize by Superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we quantify over a constraint, in simplifyInfer we need to+quantify over a constraint that is minimal in some sense: For+instance, if the final wanted constraint is (Eq alpha, Ord alpha),+we'd like to quantify over Ord alpha, because we can just get Eq alpha+from superclass selection from Ord alpha. This minimization is what+mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint+to check the original wanted.+++Note [Avoid unnecessary constraint simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -------- NB NB NB (Jun 12) -------------+    This note not longer applies; see the notes with #4361.+    But I'm leaving it in here so we remember the issue.)+    ----------------------------------------+When inferring the type of a let-binding, with simplifyInfer,+try to avoid unnecessarily simplifying class constraints.+Doing so aids sharing, but it also helps with delicate+situations like++   instance C t => C [t] where ..++   f :: C [t] => ....+   f x = let g y = ...(constraint C [t])...+         in ...+When inferring a type for 'g', we don't want to apply the+instance decl, because then we can't satisfy (C t).  So we+just notice that g isn't quantified over 't' and partition+the constraints before simplifying.++This only half-works, but then let-generalisation only half-works.++Note [DefaultTyVar]+~~~~~~~~~~~~~~~~~~~+defaultTyVar is used on any un-instantiated meta type variables to+default any RuntimeRep variables to LiftedRep.  This is important+to ensure that instance declarations match.  For example consider++     instance Show (a->b)+     foo x = show (\_ -> True)++Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),+and that won't match the typeKind (*) in the instance decl.  See tests+tc217 and tc175.++We look only at touchable type variables. No further constraints+are going to affect these type variables, so it's time to do it by+hand.  However we aren't ready to default them fully to () or+whatever, because the type-class defaulting rules have yet to run.++An alternate implementation would be to emit a Wanted constraint setting+the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. -}
+ compiler/GHC/Tc/Solver/Default.hs view
@@ -0,0 +1,1263 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiWayIf #-}++module GHC.Tc.Solver.Default(+   tryDefaulting, tryDefaultingForAmbiguityCheck,+   isInteractiveClass, isNumClass+   ) where++import GHC.Prelude++import GHC.Tc.Errors+import GHC.Tc.Errors.Types+import GHC.Tc.Types.Evidence+import GHC.Tc.Solver.Solve   ( solveSimpleWanteds, setImplicationStatus )+import GHC.Tc.Solver.Dict    ( solveCallStack )+import GHC.Tc.Utils.Unify+import GHC.Tc.Utils.TcMType as TcM+import GHC.Tc.Utils.Monad   as TcM+import GHC.Tc.Zonk.TcType     as TcM+import GHC.Tc.Solver.Solve( solveWanteds )+import GHC.Tc.Solver.Monad  as TcS+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.CtLoc( mkGivenLoc )+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType++import GHC.Core.Class+import GHC.Core.Reduction( Reduction, reductionCoercion )+import GHC.Core+import GHC.Core.DataCon+import GHC.Core.Make+import GHC.Core.Coercion( isReflCo, mkReflCo, mkSubCo, hasCoercionHole )+import GHC.Core.Unify    ( tcMatchTyKis )+import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.TyCo.Tidy++import GHC.Types.DefaultEnv ( ClassDefaults (..), defaultList )+import GHC.Types.Unique.Set+import GHC.Types.Id++import GHC.Builtin.Utils+import GHC.Builtin.Names+import GHC.Builtin.Types++import GHC.Types.TyThing ( MonadThings(lookupId) )+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Id.Make  ( unboxedUnitExpr )++import GHC.Driver.DynFlags+import GHC.Unit.Module ( getModule )++import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable++import GHC.Data.FastString+import GHC.Data.List.SetOps+import GHC.Data.Bag++import Control.Monad+import Control.Monad.Trans.Class        ( lift )+import Control.Monad.Trans.State.Strict ( StateT(runStateT), put )+import Data.Foldable      ( toList, traverse_ )+import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )+import qualified Data.List.NonEmpty as NE+import GHC.Data.Maybe     ( isJust, mapMaybe, catMaybes )+import Data.Monoid     ( First(..) )+++{- Note [Top-level Defaulting Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have considered two design choices for where/when to apply defaulting.+   (i) Do it in SimplCheck mode only /whenever/ you try to solve some+       simple constraints, maybe deep inside the context of implications.+       This used to be the case in GHC 7.4.1.+   (ii) Do it in a tight loop at simplifyTop, once all other constraints have+        finished. This is the current story.++Option (i) had many disadvantages:+   a) Firstly, it was deep inside the actual solver.+   b) Secondly, it was dependent on the context (Infer a type signature,+      or Check a type signature, or Interactive) since we did not want+      to always start defaulting when inferring (though there is an exception to+      this, see Note [Default while Inferring]).+   c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:+          f :: Int -> Bool+          f x = const True (\y -> let w :: a -> a+                                      w a = const a (y+1)+                                  in w y)+      We will get an implication constraint (for beta the type of y):+               [untch=beta] forall a. 0 => Num beta+      which we really cannot default /while solving/ the implication, since beta is+      untouchable.++Instead our new defaulting story is to pull defaulting out of the solver loop and+go with option (ii), implemented at SimplifyTop. Namely:+     - First, have a go at solving the residual constraint of the whole+       program+     - Try to approximate it with a simple constraint+     - Figure out derived defaulting equations for that simple constraint+     - Go round the loop again if you did manage to get some equations++Now, that has to do with class defaulting. However there exists type variable /kind/+defaulting. Again this is done at the top-level and the plan is:+     - At the top-level, once you had a go at solving the constraint, do+       figure out /all/ the touchable unification variables of the wanted constraints.+     - Apply defaulting to their kinds++More details in Note [DefaultTyVar].++Note [Limited defaulting in the ambiguity check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When simplifying constraints for the ambiguity check, we don't want full+defaulting.  E.g. #11947 was an example:+   f :: Num a => Int -> Int+This is ambiguous of course, but we don't want to default the (Num+alpha) constraint to (Num Int)!  Doing so gives a defaulting warning,+but no error.++But we still do++* tryConstraintDefaulting.  Example in T10009 where we have this type signature+    f :: (UnF (F b) ~ b) => F b -> ()+  We finish up with an equality that is a member of it's+    [W] hole{co_aF0} {rewriters: {co_aF0}}:: b_aES[tau:1] ~# b_aEP[sk:1]+  It is not unified because of (REWRITERS) in Note [Unification preconditions]+  in GHC.Tc.Utils.Unify++  (`tryConstraintDefaulting` defaults call-stack and exception constraint+  as well as equalities; but in the case of the ambiguity check we will+  only see equality constraints.  Does not seem worth making a version+  of `tryConstraintDefaulting` that looks only for equalities.)++* tryUnsatisfiableGivens: see Wrinkle [Ambiguity] under point (C) of+  Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors.+-}+++tryDefaulting :: WantedConstraints -> TcS WantedConstraints+-- This is the function that pulls all the defaulting strategies together+tryDefaulting wc+ = do { dflags <- getDynFlags+      ; traceTcS "tryDefaulting {" (ppr wc)+      ; wc1 <- tryTyVarDefaulting dflags wc+      ; wc2 <- tryConstraintDefaulting wc1+      ; wc3 <- tryTypeClassDefaulting wc2+      ; wc4 <- tryUnsatisfiableGivens wc3+      ; traceTcS "tryDefaulting }" (ppr wc4)+      ; return wc4 }++tryDefaultingForAmbiguityCheck  :: WantedConstraints -> TcS WantedConstraints+-- See Note [Limited defaulting in the ambiguity check]+tryDefaultingForAmbiguityCheck wc+ = do { traceTcS "tryDefaulting for ambiguity {" (ppr wc)+      ; wc1 <- tryConstraintDefaulting wc+      ; wc2 <- tryUnsatisfiableGivens wc1+      ; traceTcS "tryDefaulting }" (ppr wc2)+      ; return wc2 }++solveAgainIf :: Bool -> WantedConstraints -> TcS WantedConstraints+-- If the Bool is true, solve the wanted constraints again+-- See Note [Must simplify after defaulting]+solveAgainIf False wc = return wc+solveAgainIf True  wc = nestTcS (solveWanteds wc)+++{- ******************************************************************************+*                                                                               *+                        tryTyVarDefaulting+*                                                                               *+****************************************************************************** -}++tryTyVarDefaulting  :: DynFlags -> WantedConstraints -> TcS WantedConstraints+tryTyVarDefaulting dflags wc+  | isEmptyWC wc+  = return wc+  | insolubleWC wc+  , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]+  = return wc+  | otherwise+  = do { -- Need to zonk first, as the WantedConstraints are not yet zonked.+       ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)+       ; let defaultable_tvs = filter can_default free_tvs+             can_default tv+               =   isTyVar tv+                   -- Weed out coercion variables.++                && isMetaTyVar tv+                   -- Weed out runtime-skolems in GHCi, which we definitely+                   -- shouldn't try to default.++                && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc)+                   -- Weed out variables for which defaulting would be unhelpful,+                   -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk].++       ; unification_s <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects+       ; solveAgainIf (or unification_s) wc }+             -- solveAgainIf: see Note [Must simplify after defaulting]++type UnificationDone = Bool++noUnification, didUnification :: UnificationDone+noUnification  = False+didUnification = True++-- | Like 'defaultTyVar', but in the TcS monad.+defaultTyVarTcS :: TcTyVar -> TcS UnificationDone+defaultTyVarTcS the_tv+  | isTyVarTyVar the_tv+    -- TyVarTvs should only be unified with a tyvar+    -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar+    -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl+  = return noUnification+  | isRuntimeRepVar the_tv+  = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)+       ; unifyTyVar the_tv liftedRepTy+       ; return didUnification }+  | isLevityVar the_tv+  = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv)+       ; unifyTyVar the_tv liftedDataConTy+       ; return didUnification }+  | isMultiplicityVar the_tv+  = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)+       ; unifyTyVar the_tv ManyTy+       ; return didUnification }+  | otherwise+  = return noUnification  -- the common case+++{- ******************************************************************************+*                                                                               *+                        tryUnsatisfiableGivens+*                                                                               *+****************************************************************************** -}++-- | If an implication contains a Given of the form @Unsatisfiable msg@,+-- use it to solve all Wanteds within the implication.+-- See point (C) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors.+--+-- This does a complete walk over the implication tree.+tryUnsatisfiableGivens :: WantedConstraints -> TcS WantedConstraints+tryUnsatisfiableGivens wc =+  do { (final_wc, did_work) <- (`runStateT` False) $ go_wc wc+     ; solveAgainIf did_work final_wc }+  where+    go_wc (WC { wc_simple = wtds, wc_impl = impls, wc_errors = errs })+      = do impls' <- mapBagM go_impl impls+           return $ WC { wc_simple = wtds, wc_impl = impls', wc_errors = errs }+    go_impl impl+      | isSolvedStatus (ic_status impl)+      = return impl+      -- Is there a Given with type "Unsatisfiable msg"?+      -- If so, use it to solve all other Wanteds.+      | unsat_given:_ <- mapMaybe unsatisfiableEv_maybe (ic_given impl)+      = do { put True+           ; lift $ solveImplicationUsingUnsatGiven unsat_given impl }+      -- Otherwise, recurse.+      | otherwise+      = do { wcs' <- go_wc (ic_wanted impl)+           ; lift $ setImplicationStatus $ impl { ic_wanted = wcs' } }++-- | Is this evidence variable the evidence for an 'Unsatisfiable' constraint?+--+-- If so, return the variable itself together with the error message type.+unsatisfiableEv_maybe :: EvVar -> Maybe (EvVar, Type)+unsatisfiableEv_maybe v = (v,) <$> isUnsatisfiableCt_maybe (idType v)++-- | We have an implication with an 'Unsatisfiable' Given; use that Given to+-- solve all the other Wanted constraints, including those nested within+-- deeper implications.+solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS Implication+solveImplicationUsingUnsatGiven+  unsat_given@(given_ev,_)+  impl@(Implic { ic_wanted = wtd, ic_tclvl = tclvl, ic_binds = ev_binds_var+               , ic_need_implic = inner })+  | isCoEvBindsVar ev_binds_var+  -- We can't use Unsatisfiable evidence in kinds.+  -- See Note [Coercion evidence only] in GHC.Tc.Types.Evidence.+  = return impl+  | otherwise+  = do { wcs <- nestImplicTcS ev_binds_var tclvl $ go_wc wtd+       ; setImplicationStatus $+         impl { ic_wanted = wcs+              , ic_need_implic = inner `extendEvNeedSet` given_ev } }+                -- Record that the Given is needed; I'm not certain why+  where+    go_wc :: WantedConstraints -> TcS WantedConstraints+    go_wc wc@(WC { wc_simple = wtds, wc_impl = impls })+      = do { mapBagM_ go_simple wtds+           ; impls <- mapBagM (solveImplicationUsingUnsatGiven unsat_given) impls+           ; return $ wc { wc_simple = emptyBag, wc_impl = impls } }+    go_simple :: Ct -> TcS ()+    go_simple ct = case ctEvidence ct of+      CtWanted (WantedCt { ctev_pred = pty, ctev_dest = dest })+        -> do { ev_expr <- unsatisfiableEvExpr unsat_given pty+              ; setWantedEvTerm dest EvNonCanonical $ EvExpr ev_expr }+      _ -> return ()++-- | Create an evidence expression for an arbitrary constraint using+-- evidence for an "Unsatisfiable" Given.+--+-- See Note [Evidence terms from Unsatisfiable Givens]+unsatisfiableEvExpr :: (EvVar, ErrorMsgType) -> PredType -> TcS EvExpr+unsatisfiableEvExpr (unsat_ev, given_msg) wtd_ty+  = do { mod <- getModule+         -- If we're typechecking GHC.TypeError, return a bogus expression;+         -- it's only used for the ambiguity check, which throws the evidence away anyway.+         -- This avoids problems with circularity; where we are trying to look+         -- up the "unsatisfiable" Id while we are in the middle of typechecking it.+       ; if mod == gHC_INTERNAL_TYPEERROR then return (Var unsat_ev) else+    do { unsatisfiable_id <- tcLookupId unsatisfiableIdName++         -- See Note [Evidence terms from Unsatisfiable Givens]+         -- for a description of what evidence term we are constructing here.++       ; let -- (##) -=> wtd_ty+             fun_ty = mkFunTy visArgConstraintLike ManyTy unboxedUnitTy wtd_ty+             mkDictBox = case boxingDataCon fun_ty of+               BI_Box { bi_data_con = mkDictBox } -> mkDictBox+               _ -> pprPanic "unsatisfiableEvExpr: no DictBox!" (ppr wtd_ty)+             dictBox = dataConTyCon mkDictBox+       ; ev_bndr <- mkSysLocalM (fsLit "ct") ManyTy fun_ty+             -- Dict ((##) -=> wtd_ty)+       ; let scrut_ty = mkTyConApp dictBox [fun_ty]+             -- unsatisfiable @{LiftedRep} @given_msg @(Dict ((##) -=> wtd_ty)) unsat_ev+             scrut =+               mkCoreApps (Var unsatisfiable_id)+                 [ Type liftedRepTy+                 , Type given_msg+                 , Type scrut_ty+                 , Var unsat_ev ]+             -- case scrut of { MkDictBox @((##) -=> wtd_ty)) ct -> ct (# #) }+             ev_expr =+               mkWildCase scrut (unrestricted $ scrut_ty) wtd_ty+               [ Alt (DataAlt mkDictBox) [ev_bndr] $+                   mkCoreApps (Var ev_bndr) [unboxedUnitExpr]+               ]+        ; return ev_expr } }++{- Note [Evidence terms from Unsatisfiable Givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An Unsatisfiable Given constraint, of the form [G] Unsatisfiable msg, should be+able to solve ANY Wanted constraint whatsoever.++Recall that we have++  unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep)+                .  Unsatisfiable msg => a++We want to use this function, together with the evidence+[G] unsat_ev :: Unsatisfiable msg, to solve any other constraint [W] wtd_ty.++We could naively think that a valid evidence term for the Wanted might be:++  wanted_ev = unsatisfiable @{rep} @msg @wtd_ty unsat_ev++Unfortunately, this is a kind error: "wtd_ty :: CONSTRAINT rep", but+"unsatisfiable" expects the third type argument to be of kind "TYPE rep".++Instead, we use a boxing data constructor to box the constraint into a type.+In the end, we construct the following evidence for the implication:++  [G] unsat_ev :: Unsatisfiable msg+    ==>+      [W] wtd_ev :: wtd_ty++  wtd_ev =+    case unsatisfiable @{LiftedRep} @msg @(Dict ((##) -=> wtd_ty)) unsat_ev of+      MkDictBox ct -> ct (# #)++Note that we play the same trick with the function arrow -=> that we did+in order to define "unsatisfiable" in terms of "unsatisfiableLifted", as described+in Note [The Unsatisfiable representation-polymorphism trick] in base:GHC.TypeError.+This allows us to indirectly box constraints with different representations+(such as primitive equality constraints).+-}+++{- ******************************************************************************+*                                                                               *+                        tryConstraintDefaulting+*                                                                               *+****************************************************************************** -}++-- | A 'TcS' action which can may solve a `Ct`+type CtDefaultingStrategy = Ct -> TcS Bool+  -- True <=> I solved the constraint++tryConstraintDefaulting :: WantedConstraints -> TcS WantedConstraints+-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+tryConstraintDefaulting wc+  | isEmptyWC wc+  = return wc+  | otherwise+  = do { (n_unifs, better_wc) <- reportUnifications (go_wc wc)+         -- We may have done unifications; so solve again+       ; solveAgainIf (n_unifs > 0) better_wc }+  where+    go_wc :: WantedConstraints -> TcS WantedConstraints+    go_wc wc@(WC { wc_simple = simples, wc_impl = implics })+      = do { simples' <- mapMaybeBagM go_simple simples+           ; implics' <- mapBagM go_implic implics+           ; return (wc { wc_simple = simples', wc_impl = implics' }) }++    go_simple :: Ct -> TcS (Maybe Ct)+    go_simple ct = do { solved <- tryCtDefaultingStrategy ct+                      ; if solved then return Nothing+                                  else return (Just ct) }++    go_implic :: Implication -> TcS Implication+    -- The Maybe is because solving the CallStack constraint+    -- may well allow us to discard the implication entirely+    go_implic implic+      | isSolvedStatus (ic_status implic)+      = return implic  -- Nothing to solve inside here+      | otherwise+      = do { wanteds <- setEvBindsTcS (ic_binds implic) $+                        -- defaultCallStack sets a binding, so+                        -- we must set the correct binding group+                        go_wc (ic_wanted implic)+           ; setImplicationStatus (implic { ic_wanted = wanteds }) }++tryCtDefaultingStrategy :: CtDefaultingStrategy+-- The composition of all the CtDefaultingStrategies we want+tryCtDefaultingStrategy+  = foldr1 combineStrategies+    ( defaultCallStack :|+      defaultExceptionContext :+      defaultEquality :+      [] )++-- | Default @ExceptionContext@ constraints to @emptyExceptionContext@.+defaultExceptionContext :: CtDefaultingStrategy+defaultExceptionContext ct+  | ClassPred cls tys <- classifyPredType (ctPred ct)+  , isJust (isExceptionContextPred cls tys)+  = do { warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct)+       ; empty_ec_id <- lookupId emptyExceptionContextName+       ; let ev = ctEvidence ct+             ev_tm = EvExpr (evWrapIPE (ctEvPred ev) (Var empty_ec_id))+       ; setEvBindIfWanted ev EvCanonical ev_tm+         -- EvCanonical: see Note [CallStack and ExceptionContext hack]+         --              in GHC.Tc.Solver.Dict+       ; return True }+  | otherwise+  = return False++-- | Default any remaining @CallStack@ constraints to empty @CallStack@s.+-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+defaultCallStack :: CtDefaultingStrategy+defaultCallStack ct+  | ClassPred cls tys <- classifyPredType (ctPred ct)+  , isJust (isCallStackPred cls tys)+  = do { solveCallStack (ctEvidence ct) EvCsEmpty+       ; return True }+  | otherwise+  = return False++defaultEquality :: CtDefaultingStrategy+-- See Note [Defaulting equalities]+defaultEquality ct+  | EqPred eq_rel ty1 ty2 <- classifyPredType (ctPred ct)+  = do { -- Remember: `ct` may not be zonked;+         -- see (DE3) in Note [Defaulting equalities]+         z_ty1 <- TcS.zonkTcType ty1+       ; z_ty2 <- TcS.zonkTcType ty2+       ; case eq_rel of+          { NomEq ->+       -- Now see if either LHS or RHS is a bare type variable+       -- You might think the type variable will only be on the LHS+       -- but with a type function we might get   F t1 ~ alpha+         case (getTyVar_maybe z_ty1, getTyVar_maybe z_ty2) of+           (Just z_tv1, _) -> try_default_tv z_tv1 z_ty2+           (_, Just z_tv2) -> try_default_tv z_tv2 z_ty1+           _               -> return False ;++          ; ReprEq+              -- See Note [Defaulting representational equalities]+              | CIrredCan (IrredCt { ir_reason }) <- ct+              , isInsolubleReason ir_reason+              -- Don't do this for definitely insoluble representational+              -- equalities such as Int ~R# Bool.+              -> return False+              | otherwise+              ->+       do { traceTcS "defaultEquality ReprEq {" $ vcat+              [ text "ct:" <+> ppr ct+              , text "z_ty1:" <+> ppr z_ty1+              , text "z_ty2:" <+> ppr z_ty2+              ]+            -- Promote this representational equality to a nominal equality.+            --+            -- This handles cases such as @IO alpha[tau] ~R# IO Int@+            -- by defaulting @alpha := Int@, which is useful in practice+            -- (see Note [Defaulting representational equalities]).+          ; (co, new_eqs, _unifs) <-+              wrapUnifierX (ctEvidence ct) Nominal $+              -- NB: nominal equality!+                \ uenv -> uType uenv z_ty1 z_ty2+            -- Only accept this solution if no new equalities are produced+            -- by the unifier.+            --+            -- See Note [Defaulting representational equalities].+          ; if null new_eqs+            then do { setEvBindIfWanted (ctEvidence ct) EvCanonical $+                       (evCoercion $ mkSubCo co)+                    ; return True }+            else return False+          } } }+  | otherwise+  = return False++  where+    try_default_tv lhs_tv rhs_ty+      | MetaTv { mtv_info = info } <- tcTyVarDetails lhs_tv+      , tyVarKind lhs_tv `tcEqType` typeKind rhs_ty+      , checkTopShape info rhs_ty+      , not (hasCoercionHole rhs_ty) -- See (DE6) in Note [Defaulting equalities]+      -- Do not test for touchability of lhs_tv; that is the whole point!+      -- See (DE2) in Note [Defaulting equalities]+      = do { traceTcS "defaultEquality 1" (ppr lhs_tv $$ ppr rhs_ty)++           -- checkTyEqRhs: check that we can in fact unify lhs_tv := rhs_ty+           -- See Note [Defaulting equalities]+           ; let flags :: TyEqFlags TcM ()+                 flags = defaulting_TEFTask lhs_tv++           ; res :: PuResult () Reduction <- wrapTcS (checkTyEqRhs flags rhs_ty)++           ; case res of+               PuFail {}   -> cant_default_tv "checkTyEqRhs"+               PuOK _ redn -> assertPpr (isReflCo (reductionCoercion redn)) (ppr redn) $+                               -- With TEFA_Recurse we never get any reductions+                              default_tv }+      | otherwise+      = cant_default_tv "fall through"++      where+        cant_default_tv msg+          = do { traceTcS ("defaultEquality fails: " ++ msg) $+                 vcat [ ppr lhs_tv <+> char '~' <+>  ppr rhs_ty+                      , ppr (tyVarKind lhs_tv)+                      , ppr (typeKind rhs_ty) ]+               ; return False }++        -- All tests passed: do the unification+        default_tv+          = do { traceTcS "defaultEquality success:" (ppr rhs_ty)+               ; unifyTyVar lhs_tv rhs_ty  -- NB: unifyTyVar adds to the+                                           -- TcS unification counter+               ; setEvBindIfWanted (ctEvidence ct) EvCanonical $+                 evCoercion (mkReflCo Nominal rhs_ty)+               ; return True+               }+++combineStrategies :: CtDefaultingStrategy -> CtDefaultingStrategy -> CtDefaultingStrategy+combineStrategies default1 default2 ct+  = do { solved <- default1 ct+       ; case solved of+           True  -> return True  -- default1 solved it!+           False -> default2 ct  -- default1 failed, try default2+       }+++{- Note [When to do type-class defaulting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC+was false, on the grounds that defaulting can't help solve insoluble+constraints.  But if we *don't* do defaulting we may report a whole+lot of errors that would be solved by defaulting; these errors are+quite spurious because fixing the single insoluble error means that+defaulting happens again, which makes all the other errors go away.+This is jolly confusing: #9033.++So it seems better to always do type-class defaulting.++However, always doing defaulting does mean that we'll do it in+situations like this (#5934):+   run :: (forall s. GenST s) -> Int+   run = fromInteger 0+We don't unify the return type of fromInteger with the given function+type, because the latter involves foralls.  So we're left with+    (Num alpha, alpha ~ (forall s. GenST s) -> Int)+Now we do defaulting, get alpha := Integer, and report that we can't+match Integer with (forall s. GenST s) -> Int.  That's not totally+stupid, but perhaps a little strange.++Another potential alternative would be to suppress *all* non-insoluble+errors if there are *any* insoluble errors, anywhere, but that seems+too drastic.++Note [Defaulting equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In top-level defaulting (as per Note [Top-level Defaulting Plan]), it makes+sense to try to default equality constraints, in addition to e.g. typeclass+defaulting: this doesn't threaten principal types (see DE1 below), but+allows GHC to accept strictly more programs.++This Note explains defaulting nominal equalities; see also+Note [Defaulting representational equalities] which describes+the defaulting of representational equalities.++Consider++  f :: forall a. (forall t. (F t ~ Int) => a -> Int) -> Int++  g :: Int+  g = f id++We'll typecheck++  id :: forall t. (F t ~ Int) => alpha[1] -> Int++where the `alpha[1]` comes from instantiating `f`. So we'll end up+with the implication constraint++   forall[2] t. (F t ~ Int) => alpha[1] ~ Int++and that can't be solved because `alpha` is untouchable under the+equality (F t ~ Int).++This is tiresome, and gave rise to user complaints: #25125 and #25029.+Moreover, in this case there is no good reason not to unify alpha:=Int.+Doing so solves the constraint, and since `alpha` is not otherwise+constrained, it does no harm.++In conclusion, for a Wanted equality constraint [W] lhs ~ rhs, if the only+reason for not unifying is that either lhs or rhs is an untouchable metavariable+then, in top-level defaulting, go ahead and unify.++In top-level defaulting, we already do several other somewhat-ad-hoc,+but terribly convenient, unifications. This is just one more.++Wrinkles:++(DE1) Note carefully that this does not threaten principal types.+  The original worry about unifying untouchable type variables was this:++     data T a where+       T1 :: T Bool+     f x = case x of T1 -> True++  Should we infer f :: T a -> Bool, or f :: T a -> a.  Both are valid, but+  neither is more general than the other.++(DE2) We still can't unify if there is a skolem-escape check, or an occurs check,+  or it it'd mean unifying a TyVarTv with a non-tyvar.  It's only the+  "untouchability test" that we lift.++(DE3) The contraint we are looking at may not be fully zonked; for example,+  an earlier defaulting might have affected it. So we zonk-on-the fly in+  `defaultEquality`.++(DE4) Promotion. Suppose we see  alpha[2] := Maybe beta[4].  We want to promote+  beta[4] to level 2 and unify alpha[2] := Maybe beta'[2].  This is done by+  checkTyEqRhs called in defaultEquality.++(DE5) Promotion. Suppose we see  alpha[2] := F beta[4], where F is a type+  family. Then we still want to promote beta to beta'[2], and unify. This is+  unusual: more commonly, we don't promote unification variables under a+  type family.  But here we want to.  (This mattered in #25251.)++  Hence the Bool flag on LC_Promote, and its use in `tef_unifying` in+  `defaultEquality`.++(DE6) /Don't/ unify if the RHS has a free coercion hole in it.  That means+  that there is an as-yet-unsolved equality constraint (whose evidence+  will fill that hole); unifying can lead to very confusing type errors.+  e.g.    [W] co1 :: IntRep ~ LiftedRep+          [W] co2 {rewritten by co1} :: alpha ~ t2 |> (TYPE co1)+  Unifying alpha := (t1 |> TYPE co1) is a Bad Idea.++  Note that we /do/ unify even if the constraint has a non-empty rewriter+  set, which has prevented unification up to now; see+  Note [Unify only if the rewriter set is empty] in GHC.Tc.Solver.Equality.+  In obscure situations a constraint can end up in its own rewriter set, but+  without a coercion hole being in the RHS.++  See #10009, and Note [Limited defaulting in the ambiguity check].+++Note [Must simplify after defaulting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may have a deeply buried constraint+    (t:*) ~ (a:Open)+which we couldn't solve because of the kind incompatibility, and 'a' is free.+Then when we default 'a' we can solve the constraint.  And we want to do+that before starting in on type classes.  We MUST do it before reporting+errors, because it isn't an error!  #7967 was due to this.++Note [Defaulting representational equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we end up with [W] alpha ~#R Int, with no other constraints on alpha.+Then it makes sense to simply unify alpha := Int -- the alternative is to+reject the program due to an ambiguous metavariable alpha, so it makes sense+to unify and accept instead.++This is particularly convenient for users of `coerce`, as it lessens the+amount of type annotations required (see #21003). Consider for example:++  -- 'foldMap' defined using 'traverse'+  foldMapUsingTraverse :: forall t m a. (Traversable t, Monoid m) => (a -> m) -> t a -> m+  foldMapUsingTraverse = coerce $ traverse @t @(Const m)++  -- 'traverse_' defined using 'foldMap'+  traverse_UsingFoldMap :: forall f t a. (Foldable t, Applicative f) => (a -> f ()) -> t a -> f ()+  traverse_UsingFoldMap = coerce $ foldMap @t @(Ap f ())++Typechecking these functions results in unsolved Wanted constraints of the form+[W] alpha[tau] ~R# some_ty; accepting such programs by unifying+alpha := some_ty avoids the need for users to specify tiresome additional+type annotations, such as:++    foldMapUsingTraverse = coerce $ traverse @t @(Const m) @a+    traverse_UsingFoldMap = coerce $ foldMap @t @(Ap f ()) @a++Consider also the following example:++  -- 'sequence_', but for two nested 'Foldable' structures+  sequenceNested_ :: forall f1 f2. (Foldable f1, Foldable f2) => f1 (f2 (IO ())) -> IO ()+  sequenceNested_ = coerce $ sequence_ @( Compose f1 f2 )++Here, we end up with [W] mu[tau] beta[tau] ~#R IO (), and it similarly makes+sense to default mu := IO, beta := (). This avoids requiring the+user to provide additional type applications:++    sequenceNested_ = coerce $ sequence_ @( Compose f1 f2 ) @IO @()++The plan for defaulting a representational equality, say [W] ty1 ~R# ty2,+is thus as follows:++  1. attempt to unify ty1 ~# ty2 (at nominal role)+  2. a. if this succeeds without deferring any constraints, accept this solution+     b. otherwise, keep the original constraint.++(2b) ensures that we don't degrade all error messages by always turning unsolved+representational equalities into nominal ones; we only want to default a+representational equality when we can fully solve it.++Note that this does not threaten principle types. Recall that the original worry+(as per Note [Do not unify representational equalities]) was that we might have++    [W] alpha ~R# Int+    [W] alpha ~ Age++in which case unifying alpha := Int would be wrong, as the correct solution is+alpha := Age. This worry doesn't concern us in top-level defaulting, because+defaulting takes place after generalisation; it is fully monomorphic.++*********************************************************************************+*                                                                               *+*                Type-class defaulting+*                                                                               *+*********************************************************************************++Note [How type-class constraints are defaulted]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type-class defaulting deals with the situation where we have unsolved+constraints like (Num alpha), where `alpha` is a unification variable.  We want+to pick a default for `alpha`, such as `alpha := Int` to resolve the ambiguity.++The function 'tryTypeClassDefaulting' implements type-class defaulting. The+algorithm for defaulting depends on whether certain extensions are enabled,+such as -XOverloadedStrings or -XExtendedDefaultRules. To explain this, let us+define the following:++  Unary typeclass:+    a typeclass with a single visible type argument.++    Examples:++      Num :: Type -> Constraint+      Eq :: Type -> Constraint+      Foldable :: (Type -> Type) -> Constraint+      Typeable :: forall k. k -> Constraint   -- NB: also has an /invisible/ argument++    Non-examples:++      Nullary :: Constraint+      Binary :: Type -> Type -> Constraint+      Binary2 :: forall k -> k -> Constraint  -- Two visible arguments++  Defaultable class+    a typeclass which has at least one in-scope default declaration++    This includes the two different categories of default declarations:++      - Haskell 98 default declarations such as 'default (Integer, Float)'.++        - `Num` is always defaultable; either the user says 'default( Integer, Float )'+          or (absent such a declaration) the system fills in a fallback default declaration.+          See Section 4.3.4 in https://www.haskell.org/onlinereport/haskell2010/haskellch4.html++        - With `OverloadedStrings`, the class `IsString` is defaultable+        - With `ExtendedDefaultRules`, the classes `Show`, `Eq`, `Ord`, `Foldable` and `Traversable`+          are defaultable++      - Named default declarations, which apply to the named class, e.g.+        'default Cls(X, Y)' applies precisely to 'Cls'.+        Note that these may be locally defined, or they may be imported.++  Standard class:+    a class defined in the Prelude or the standard library, as defined+    by the Haskell 98 report (section 4.3.4)++    These are defined in GHC.Builtin.Names.standardClassKeys.++The rules for defaulting a collection 'S' of unsolved constraints are as follows:++  1. For each metavariable 'v' appearing in 'S', define++       U_v = { C v | C v ∈ U, C is a unary typeclass }++     We then process each 'U_v' in turn, in order to find a defaulting+     assignment 'v := ty' that solves all of 'U_v'.++  2. Unless -XExtendedDefaultRules is in effect, give up if 'v' appears:++      - in any constraint that isn't a unary class constraint+      - in a class constraint which is non-standard and does not have+        a default declaration in scope.++  3. Compute candidate assignments: for each unary typeclass 'C' in 'U_v' which+     has a default declaration in scope, find the first type 'ty' in the list+     of in-scope default types for 'C' for which all of 'U_v' is soluble.++  4. If there is precisely one type candidate type assignment 'ty' that allows+     all of 'U_v' to be solved, we default 'v := ty'. Otherwise, do nothing+     ('v' remains ambiguous).++Note [Defaulting plugins]+~~~~~~~~~~~~~~~~~~~~~~~~~+Defaulting plugins enable extending or overriding the defaulting+behaviour. In `applyDefaultingRules`, before the built-in defaulting+mechanism runs, the loaded defaulting plugins are passed the+`WantedConstraints` and get a chance to propose defaulting assignments+based on them.++Proposals are represented as `[DefaultingProposal]` with each proposal+consisting of a type variable to fill-in, the list of defaulting types to+try in order, and a set of constraints to check at each try. This is+the same representation (albeit in a nicely packaged-up data type) as+the candidates generated by the built-in defaulting mechanism, so the+actual trying of proposals is done by the same `disambigGroup` function.++Wrinkle (DP1): The role of `WantedConstraints`++  Plugins are passed `WantedConstraints` that can perhaps be+  progressed on by defaulting. But a defaulting plugin is not a solver+  plugin, its job is to provide defaulting proposals, i.e. mappings of+  type variable to types. How do plugins know which type variables+  they are supposed to default?++  The `WantedConstraints` passed to the defaulting plugin are zonked+  beforehand to ensure all remaining metavariables are unfilled. Thus,+  the `WantedConstraints` serve a dual purpose: they are both the+  constraints of the given context that can act as hints to the+  defaulting, as well as the containers of the type variables under+  consideration for defaulting.++Wrinkle (DP2): Interactions between defaulting mechanisms++  In the general case, we have multiple defaulting plugins loaded and+  there is also the built-in defaulting mechanism. In this case, we+  have to be careful to keep the `WantedConstraints` passed to the+  plugins up-to-date by zonking between successful defaulting+  rounds. Otherwise, two plugins might come up with a defaulting+  proposal for the same metavariable; if the first one is accepted by+  `disambigGroup` (thus the meta gets filled), the second proposal+  becomes invalid (see #23821 for an example).++Note [Defaulting insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a set of wanteds is insoluble, we have no hope of accepting the+program. Yet we do not stop constraint solving, etc., because we may+simplify the wanteds to produce better error messages. So, once+we have an insoluble constraint, everything we do is just about producing+helpful error messages.++Should we default in this case or not? Let's look at an example (tcfail004):++  (f,g) = (1,2,3)++With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer).+Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard)+find the latter more helpful. Several other test cases (e.g. tcfail005) suggest+similarly. So: we should not do class defaulting with insolubles.++On the other hand, RuntimeRep-defaulting is different. Witness tcfail078:++  f :: Integer i => i+  f =               0++Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind+TYPE r0 -> Constraint and then complains that r0 is actually untouchable+(presumably, because it can't be sure if `Integer i` entails an equality).+If we default, we are told of a clash between (* -> Constraint) and Constraint.+The latter seems far better, suggesting we *should* do RuntimeRep-defaulting+even on insolubles.++But, evidently, not always. Witness UnliftedNewtypesInfinite:++  newtype Foo = FooC (# Int#, Foo #)++This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes).+If we default RuntimeRep-vars, we get++  Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted++which is just plain wrong.++Another situation in which we don't want to default involves concrete metavariables.++In equalities such as   alpha[conc] ~# rr[sk]  ,  alpha[conc] ~# RR beta[tau]+for a type family RR (all at kind RuntimeRep), we would prefer to report a+representation-polymorphism error rather than default alpha and get error:++  Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted`++which is very confusing. For this reason, we weed out the concrete+metavariables participating in such equalities in nonDefaultableTyVarsOfWC.+Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could+become soluble after defaulting beta (see also #21430).++Conclusion: we should do RuntimeRep-defaulting on insolubles only when the+user does not want to hear about RuntimeRep stuff -- that is, when+-fprint-explicit-runtime-reps is not set.+However, we must still take care not to default concrete type variables+participating in an equality with a non-concrete type, as seen in the+last example above.++-}++tryTypeClassDefaulting :: WantedConstraints -> TcS WantedConstraints+tryTypeClassDefaulting wc+  | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]+  = return wc+  | otherwise  -- See Note [When to do type-class defaulting]+  = do { something_happened <- applyDefaultingRules wc+                               -- See Note [Top-level Defaulting Plan]+       ; solveAgainIf something_happened wc }++applyDefaultingRules :: WantedConstraints -> TcS Bool+-- True <=> I did some defaulting, by unifying a meta-tyvar+-- Input WantedConstraints are not necessarily zonked+-- See Note [How type-class constraints are defaulted]++applyDefaultingRules wanteds+  | isEmptyWC wanteds+  = return False+  | otherwise+  = do { (default_env, extended_rules) <- getDefaultInfo+       ; wanteds                       <- TcS.zonkWC wanteds++       ; tcg_env <- TcS.getGblEnv+       ; let plugins = tcg_defaulting_plugins tcg_env+             default_tys = defaultList default_env+             -- see Note [Named default declarations] in GHC.Tc.Gen.Default++       -- Run any defaulting plugins+       -- See Note [Defaulting plugins] for an overview+       ; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else+           do {+             ; traceTcS "defaultingPlugins {" (ppr wanteds)+             ; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins+             ; traceTcS "defaultingPlugins }" (ppr defaultedGroups)+             ; return (wanteds, defaultedGroups)+             }++       ; let groups = findDefaultableGroups (default_tys, extended_rules) wanteds++       ; traceTcS "applyDefaultingRules {" $+                  vcat [ text "wanteds =" <+> ppr wanteds+                       , text "groups  =" <+> ppr groups+                       , text "info    =" <+> ppr (default_tys, extended_rules) ]++       ; something_happeneds <- mapM (disambigGroup wanteds default_tys) groups++       ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)++       ; return $ or something_happeneds || or plugin_defaulted }++    where+      run_defaulting_plugin wanteds p+          = do { groups <- runTcPluginTcS (p wanteds)+               ; defaultedGroups <-+                    filterM (\g -> disambigMultiGroup+                                   wanteds+                                   (deProposalCts g)+                                   (ProposalSequence (Proposal <$> deProposals g)))+                    groups+               ; traceTcS "defaultingPlugin " $ ppr defaultedGroups+               ; case defaultedGroups of+                 [] -> return (wanteds, False)+                 _  -> do+                     -- If a defaulting plugin solves any tyvars, some of the wanteds+                     -- will have filled-in metavars by now (see wrinkle DP2 of+                     -- Note [Defaulting plugins]). So we re-zonk to make sure later+                     -- defaulting doesn't try to solve the same metavars.+                     wanteds' <- TcS.zonkWC wanteds+                     return (wanteds', True) }++findDefaultableGroups+    :: ( [ClassDefaults]+       , Bool )            -- extended default rules+    -> WantedConstraints   -- Unsolved+    -> [(TyVar, [Ct])]+findDefaultableGroups (default_tys, extended_defaults) wanteds+  | null default_tys+  = []+  | otherwise+  = [ (tv, map fstOf3 group)+    | group'@((_,_,tv) :| _) <- unary_groups+    , let group = toList group'+    , defaultable_tyvar tv+    , defaultable_classes (map sndOf3 group) ]+  where+    simples  = approximateWC True wanteds+      -- True: for the purpose of defaulting we don't care+      --       about shape or enclosing equalities+      -- See (W3) in Note [ApproximateWC] in GHC.Tc.Types.Constraint++    (unaries, non_unaries) = partitionWith find_unary (bagToList simples)+    unary_groups           = equivClasses cmp_tv unaries++    unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints+    unaries      :: [(Ct, Class, TcTyVar)]          -- (C tv) constraints+    non_unaries  :: [Ct]                            -- and *other* constraints++    -- Finds unary type-class constraints+    -- But take account of polykinded classes like Typeable,+    -- which may look like (Typeable Type (a:Type))   (#8931)+    -- See step (1) in Note [How type-class constraints are defaulted]+    find_unary :: Ct -> Either (Ct, Class, TyVar) Ct+    find_unary cc+        | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)+        , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys+              -- Ignore invisible arguments for this purpose+        , Just tv <- getTyVar_maybe ty+        , isMetaTyVar tv  -- We might have runtime-skolems in GHCi, and+                          -- we definitely don't want to try to assign to those!+        = Left (cc, cls, tv)+    find_unary cc = Right cc  -- Non unary or non dictionary++    nonunary_tvs :: TcTyCoVarSet  -- TyVars mentioned by non-unaries+    nonunary_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries++    cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2++    defaultable_tyvar :: TcTyVar -> Bool+    defaultable_tyvar tv+        = let b1 = isTyConableTyVar tv  -- Note [Avoiding spurious errors]+              b2 = not (tv `elemVarSet` nonunary_tvs)+          in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults]++    -- Determines whether the collection of class constraints permits defaulting.+    -- See step (2) in Note [How type-class constraints are defaulted]+    defaultable_classes :: [Class] -> Bool+    defaultable_classes clss =+      -- One of the classes has a default declaration in scope+      -- (this includes 'Num', and e.g. 'IsString' with -XOverloadedStrings)+      any (`elementOfUniqSet` classes_with_defaults) clss+        &&+      -- AND, either:+      --  - ExtendedDefaultRules is in effect, or+      --  - all the classes are standard or have a default declaration in scope+      (extended_defaults || all is_std_or_has_default clss)+    is_std_or_has_default :: Class -> Bool+    is_std_or_has_default cls =+      (getUnique cls `elem` standardClassKeys)+        ||+      (cls `elementOfUniqSet` classes_with_defaults)++    -- All classes with a default declaration in scope; either:+    --+    --  - a named default declaration such as 'default C(Double, Bool)', or+    --  - a Haskell 98 default declaration such as 'default(Int, Float)',+    --    which adds defaults for Num, for IsString with OverloadedStrings,+    --    and for Foldable/Traversable/... with ExtendedDefaultRules+    classes_with_defaults = mkUniqSet $ map cd_class default_tys++------------------------------++-- | 'Proposal's to be tried in sequence until the first one that succeeds+newtype ProposalSequence = ProposalSequence{getProposalSequence :: [Proposal]}++-- | An atomic set of proposed type assignments to try applying all at once+newtype Proposal = Proposal [(TcTyVar, Type)]++instance Outputable ProposalSequence where+  ppr (ProposalSequence proposals) = ppr proposals+instance Outputable Proposal where+  ppr (Proposal assignments) = ppr assignments++disambigGroup :: WantedConstraints -- ^ Original constraints, for diagnostic purposes+              -> [ClassDefaults]   -- ^ The default classes and types+              -> (TcTyVar, [Ct])   -- ^ All constraints sharing same type variable+              -> TcS Bool   -- True <=> something happened, reflected in ty_binds+disambigGroup orig_wanteds default_ctys (tv, wanteds)+  = disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent+  where+    proposalSequences = [ ProposalSequence [Proposal [(tv, ty)] | ty <- tys]+                        | ClassDefaults{cd_types = tys} <- defaultses ]+    allConsistent ((_, sub) :| subs) = all (eqSubAt tv sub . snd) subs+    defaultses =+      [ defaults | defaults@ClassDefaults{cd_class = cls} <- default_ctys+                 , any (isDictForClass (className cls)) wanteds ]+    isDictForClass clcon ct = any ((clcon ==) . className . fst) (getClassPredTys_maybe $ ctPred ct)+    eqSubAt :: TcTyVar -> Subst -> Subst -> Bool+    eqSubAt tvar s1 s2 = or $ liftA2 tcEqType (lookupTyVar s1 tvar) (lookupTyVar s2 tvar)++-- See Note [How type-class constraints are defaulted]+disambigMultiGroup :: WantedConstraints    -- ^ Original constraints, for diagnostic purposes+                   -> [Ct]                 -- ^ check these are solved by defaulting+                   -> ProposalSequence     -- ^ defaulting type assignments to try+                   -> TcS Bool   -- True <=> something happened, reflected in ty_binds+disambigMultiGroup orig_wanteds wanteds proposalSequence+  = disambigProposalSequences orig_wanteds wanteds [proposalSequence] (const True)++disambigProposalSequences :: WantedConstraints   -- ^ Original constraints, for diagnostic purposes+                          -> [Ct]                -- ^ Check these are solved by defaulting+                          -> [ProposalSequence]  -- ^ The sequences of assignment proposals+                          -> (NonEmpty ([TcTyVar], Subst) -> Bool)+                                                 -- ^ Predicate for successful assignments+                          -> TcS Bool   -- True <=> something happened, reflected in ty_binds+disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent+  = do { traverse_ (traverse_ reportInvalidDefaultedTyVars . getProposalSequence) proposalSequences+       ; fake_ev_binds_var <- TcS.newTcEvBinds+       ; tclvl             <- TcS.getTcLevel+       -- Step (3) in Note [How type-class constraints are defaulted]+       ; successes <- fmap catMaybes $+                      nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $+                      mapM firstSuccess proposalSequences+       ; traceTcS "disambigProposalSequences {" (vcat [ ppr wanteds+                                                      , ppr proposalSequences+                                                      , ppr successes ])+       -- Step (4) in Note [How type-class constraints are defaulted]+       ; case successes of+           success@(tvs, subst) : rest+             | allConsistent (success :| rest)+             -> do { applyDefaultSubst tvs subst+                   ; let warn tv = mapM_ (warnDefaulting wanteds tv) (lookupTyVar subst tv)+                   ; wrapWarnTcS $ mapM_ warn tvs+                   ; traceTcS "disambigProposalSequences succeeded }" (ppr proposalSequences)+                   ; return True }+           _ ->+             do { traceTcS "disambigProposalSequences failed }" (ppr proposalSequences)+                ; return False } }+  where+    reportInvalidDefaultedTyVars :: Proposal -> TcS ()+    firstSuccess :: ProposalSequence -> TcS (Maybe ([TcTyVar], Subst))+    firstSuccess (ProposalSequence proposals)+      = getFirst <$> foldMapM (fmap First . tryDefaultGroup wanteds) proposals+    reportInvalidDefaultedTyVars proposal@(Proposal assignments)+      = do { let tvs = fst <$> assignments+             ; invalid_tvs <- filterOutM TcS.isUnfilledMetaTyVar tvs+             ; traverse_ (errInvalidDefaultedTyVar orig_wanteds proposal) (nonEmpty invalid_tvs) }++applyDefaultSubst :: [TcTyVar] -> Subst -> TcS ()+applyDefaultSubst tvs subst =+  do { deep_tvs <- filterM TcS.isUnfilledMetaTyVar $ nonDetEltsUniqSet $ closeOverKinds (mkVarSet tvs)+     ; forM_ deep_tvs $ \ tv -> mapM_ (unifyTyVar tv) (lookupVarEnv (getTvSubstEnv subst) tv)+     }++tryDefaultGroup :: [Ct]       -- ^ check these are solved by defaulting+                -> Proposal   -- ^ defaulting type assignments to try+                -> TcS (Maybe ([TcTyVar], Subst))  -- ^ successful substitutions, *not* reflected in ty_binds+tryDefaultGroup wanteds (Proposal assignments)+          | let (tvs, default_tys) = unzip assignments+          , Just subst <- tcMatchTyKis (mkTyVarTys tvs) default_tys+            -- Make sure the kinds match too; hence this call to tcMatchTyKi+            -- E.g. suppose the only constraint was (Typeable k (a::k))+            -- With the addition of polykinded defaulting we also want to reject+            -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.+          = do { lcl_env <- TcS.getLclEnv+               ; tc_lvl <- TcS.getTcLevel+               ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)+                     new_wtd_ct :: WantedCtEvidence -> TcS Ct+                     new_wtd_ct (WantedCt { ctev_pred = wtd_pred, ctev_rewriters = rws }) =+                       mkNonCanonical . CtWanted <$>+                         -- NB: equality constraints are possible,+                         -- due to type defaulting plugins+                         newWantedNC loc rws (substTy subst wtd_pred)+               ; new_wanteds <- sequence [ new_wtd_ct wtd+                                         | CtWanted wtd <- map ctEvidence wanteds+                                         ]+               ; residual <- solveSimpleWanteds (listToBag new_wanteds)+               ; return $ if isEmptyWC residual then Just (tvs, subst) else Nothing }++          | otherwise+          = return Nothing++errInvalidDefaultedTyVar :: WantedConstraints -> Proposal -> NonEmpty TcTyVar -> TcS ()+errInvalidDefaultedTyVar wanteds (Proposal assignments) problematic_tvs+  = failTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_assignments tidy_problems+  where+    proposal_tvs = concatMap (\(tv, ty) -> tv : tyCoVarsOfTypeList ty) assignments+    tidy_env = tidyFreeTyCoVars emptyTidyEnv $ proposal_tvs ++ NE.toList problematic_tvs+    tidy_wanteds = map (tidyCt tidy_env) $ flattenWC wanteds+    tidy_assignments = [(tidyTyCoVarOcc tidy_env tv, tidyType tidy_env ty) | (tv, ty) <- assignments]+    tidy_problems = fmap (tidyTyCoVarOcc tidy_env) problematic_tvs++    flattenWC :: WantedConstraints -> [Ct]+    flattenWC (WC { wc_simple = cts, wc_impl = impls })+      = ctsElts cts ++ concatMap (flattenWC . ic_wanted) impls++-- In interactive mode, or with -XExtendedDefaultRules,+-- we default Show a to Show () to avoid gratuitous errors on "show []"+isInteractiveClass :: Bool   -- -XOverloadedStrings?+                   -> Class -> Bool+isInteractiveClass ovl_strings cls+    = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys)++    -- isNumClass adds IsString to the standard numeric classes,+    -- when -XOverloadedStrings is enabled+isNumClass :: Bool   -- -XOverloadedStrings?+           -> Class -> Bool+isNumClass ovl_strings cls+  = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))+++{-+Note [Avoiding spurious errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When doing the unification for defaulting, we check for skolem+type variables, and simply don't default them.  For example:+   f = (*)      -- Monomorphic+   g :: Num a => a -> a+   g x = f x x+Here, we get a complaint when checking the type signature for g,+that g isn't polymorphic enough; but then we get another one when+dealing with the (Num a) context arising from f's definition;+we try to unify a with Int (to default it), but find that it's+already been unified with the rigid variable from g's type sig.++Note [Multi-parameter defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With -XExtendedDefaultRules, we default only based on single-variable+constraints, but do not exclude from defaulting any type variables which also+appear in multi-variable constraints. This means that the following will+default properly:++   default (Integer, Double)++   class A b (c :: Symbol) where+      a :: b -> Proxy c++   instance A Integer c where a _ = Proxy++   main = print (a 5 :: Proxy "5")++Note that if we change the above instance ("instance A Integer") to+"instance A Double", we get an error:++   No instance for (A Integer "5")++This is because the first defaulted type (Integer) has successfully satisfied+its single-parameter constraints (in this case Num).+-}
compiler/GHC/Tc/Solver/Dict.hs view
@@ -1,47 +1,53 @@+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiWayIf #-}  -- | Solving Class constraints CDictCan module GHC.Tc.Solver.Dict (-  solveDict, solveDictNC,+  solveDict, solveDictNC, solveCallStack,   checkInstanceOK,   matchLocalInst, chooseInstance,   makeSuperClasses, mkStrictSuperClasses,-  solveCallStack    -- For GHC.Tc.Solver   ) where  import GHC.Prelude +import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds )+ import GHC.Tc.Errors.Types import GHC.Tc.Instance.FunDeps-import GHC.Tc.Instance.Class( safeOverlap, matchEqualityInst )+import GHC.Tc.Instance.Class( matchEqualityInst ) import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Origin-import GHC.Tc.Types.EvTerm( evCallStack ) import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Tc.Solver.Types import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Unify( uType )+import GHC.Tc.Utils.Unify( uType, mightEqualLater )  import GHC.Hs.Type( HsIPName(..) )  import GHC.Core+import GHC.Core.Make import GHC.Core.Type import GHC.Core.InstEnv     ( DFunInstType, ClsInst(..) ) import GHC.Core.Class import GHC.Core.Predicate import GHC.Core.Multiplicity ( scaledThing )-import GHC.Core.Unify ( ruleMatchTyKiX , typesAreApart )+import GHC.Core.Unify ( ruleMatchTyKiX ) +import GHC.Types.TyThing( lookupDataCon, lookupId ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Var import GHC.Types.Id( mkTemplateLocals ) import GHC.Types.Var.Set import GHC.Types.Var.Env+import GHC.Types.SrcLoc +import GHC.Builtin.Names( srcLocDataConName, pushCallStackName, emptyCallStackName )+ import GHC.Utils.Monad ( concatMapM, foldlM ) import GHC.Utils.Outputable import GHC.Utils.Panic@@ -58,11 +64,8 @@ import Data.Maybe ( listToMaybe, mapMaybe, isJust ) import Data.Void( Void ) -import Control.Monad.Trans.Maybe( MaybeT, runMaybeT )-import Control.Monad.Trans.Class( lift ) import Control.Monad - {- ********************************************************************* *                                                                      * *                      Class Canonicalization@@ -101,30 +104,6 @@        ; simpleStage (updInertDicts dict_ct)        ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" } -updInertDicts :: DictCt -> TcS ()-updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })-  = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls  <+> ppr tys)--       ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys-            -> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]-               -- Update /both/ inert_cans /and/ inert_solved_dicts.-               updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->-               inerts { inert_cans         = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics-                      , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }-            | otherwise-            -> return ()--       -- Add the new constraint to the inert set-       ; updInertCans (updDicts (addDict dict_ct)) }-  where-    -- Does this class constraint or any of its superclasses mention-    -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?-    does_not_mention_ip_for :: Type -> DictCt -> Bool-    does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })-      = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys-        -- See Note [Using typesAreApart when calling mentionsIP]-        -- in GHC.Core.Predicate- canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt -- Once-only processing of Dict constraints: --   * expand superclasses@@ -142,29 +121,29 @@          -- doNotExpand: We have already expanded superclasses for /this/ dict          -- so set the fuel to doNotExpand to avoid repeating expansion -  | CtWanted { ctev_rewriters = rewriters } <- ev+  | CtWanted (WantedCt { ctev_rewriters = rws }) <- ev   , Just ip_name <- isCallStackPred cls tys-  , isPushCallStackOrigin orig+  , Just fun_fs  <- isPushCallStackOrigin_maybe orig   -- If we're given a CallStack constraint that arose from a function   -- 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.Types+  -- and Note [Solving CallStack constraints]   = Stage $     do { -- First we emit a new constraint that will capture the          -- given CallStack.+          let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))                             -- We change the origin to IPOccOrigin so                             -- this rule does not fire again.                             -- See Note [Overview of implicit CallStacks]                             -- in GHC.Tc.Types.Evidence -       ; new_ev <- newWantedEvVarNC new_loc rewriters pred+       ; new_ev <- CtWanted <$> newWantedEvVarNC new_loc rws pred           -- Then we solve the wanted by pushing the call-site          -- onto the newly emitted CallStack-       ; let ev_cs = EvCsPushCall (callStackOriginFS orig)-                                  (ctLocSpan loc) (ctEvExpr new_ev)+       ; let ev_cs = EvCsPushCall fun_fs (ctLocSpan loc) (ctEvExpr new_ev)        ; solveCallStack ev ev_cs         ; continueWith (DictCt { di_ev = new_ev, di_cls = cls@@ -180,31 +159,96 @@                   -- See Invariants in `CCDictCan.cc_pend_sc`        ; continueWith (DictCt { di_ev = ev, di_cls = cls                               , di_tys = tys, di_pend_sc = fuel }) }+   where     loc  = ctEvLoc ev     orig = ctLocOrigin loc     pred = ctEvPred ev +{- *********************************************************************+*                                                                      *+*           Implicit parameters and call stacks+*                                                                      *+********************************************************************* -}+ solveCallStack :: CtEvidence -> EvCallStack -> TcS () -- Also called from GHC.Tc.Solver when defaulting call stacks solveCallStack ev ev_cs   -- We're given ev_cs :: CallStack, but the evidence term should be a   -- dictionary, so we have to coerce ev_cs to a dictionary for   -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]-  = do { cs_tm <- evCallStack ev_cs-       ; let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))+  = do { inner_stk <- evCallStack pred ev_cs+       ; let ev_tm = EvExpr (evWrapIPE pred inner_stk)        ; setEvBindIfWanted ev EvCanonical ev_tm }-         -- EvCanonical: see Note [CallStack and ExecptionContext hack]+         -- EvCanonical: see Note [CallStack and ExceptionContext hack]+  where+    pred = ctEvPred ev -{- Note [CallStack and ExecptionContext hack]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Dictionary for CallStack implicit parameters+evCallStack :: TcPredType -> EvCallStack -> TcS EvExpr+-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+evCallStack _ EvCsEmpty+  = Var <$> lookupId emptyCallStackName+evCallStack pred (EvCsPushCall fs loc tm)+  = do { df <- getDynFlags+       ; m  <- getModule+       ; srcLocDataCon <- lookupDataCon srcLocDataConName+       ; let platform = targetPlatform df+             mkSrcLoc l = mkCoreConWrapApps srcLocDataCon <$>+                          sequence [ mkStringExprFS (unitFS $ moduleUnit m)+                                   , mkStringExprFS (moduleNameFS $ moduleName m)+                                   , mkStringExprFS (srcSpanFile l)+                                   , return $ mkIntExprInt platform (srcSpanStartLine l)+                                   , return $ mkIntExprInt platform (srcSpanStartCol l)+                                   , return $ mkIntExprInt platform (srcSpanEndLine l)+                                   , return $ mkIntExprInt platform (srcSpanEndCol l)+                                   ]++       ; push_cs_id <- lookupId pushCallStackName+       ; name_expr  <- mkStringExprFS fs+       ; loc_expr   <- mkSrcLoc loc+               -- At this point tm :: IP sym CallStack+               -- but we need the actual CallStack to pass to pushCS,+               -- so we use evUwrapIP to strip the dictionary wrapper+               -- See Note [Overview of implicit CallStacks]+       ; let outer_stk = evUnwrapIPE pred tm+       ; return (mkCoreApps (Var push_cs_id)+                    [mkCoreTup [name_expr, loc_expr], outer_stk]) }++{- Note [Solving CallStack constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence.++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 canonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, 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.  We guarantee+this by canonicalising before looking up in the inert set.++Note [CallStack and ExceptionContext hack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It isn't really right that we treat CallStack and ExceptionContext dictionaries as canonical, in the sense of Note [Coherence and specialisation: overview]. They definitely are not!  But if we use EvNonCanonical here we get lots of     nospec (error @Int) dict  string-(since `error` takes a HasCallStack dict), and that isn't bottomng  (at least not+(since `error` takes a HasCallStack dict), and that isn't bottoming  (at least not without extra work)  So, hackily, we just say that HasCallStack and ExceptionContext are canonical, even though they aren't really. @@ -368,6 +412,11 @@   pattern matching. Its compile-time allocation decreased by 40% when   I added the "replace" rather than "add" semantics.) +  We achieve this by+   (a) not expanding superclasses for equality classes at all;+       see the `isEqualityClass` test in `mk_strict_superclasses`+   (b) special logic to solve (t1 ~ t2) in `solveEqualityDict`.+ (EQC2) Faced with [W] t1 ~ t2, it's always OK to reduce it to [W] t1 ~# t2,   without worrying about Note [Instance and Given overlap].  Why?  Because   if we had [G] s1 ~ s2, then we'd get the superclass [G] s1 ~# s2, and@@ -417,27 +466,29 @@ -}  solveEqualityDict :: CtEvidence -> Class -> [Type] -> SolverStage Void+-- See Note [Solving equality classes] -- Precondition: (isEqualityClass cls) True, so cls is (~), (~~), or Coercible solveEqualityDict ev cls tys-  | CtWanted { ctev_dest = dest } <- ev+  | CtWanted (WantedCt { ctev_dest = dest }) <- ev   = Stage $-    do { let (data_con, role, t1, t2) = matchEqualityInst cls tys+    do { let (role, t1, t2) = matchEqualityInst cls tys          -- Unify t1~t2, putting anything that can't be solved          -- immediately into the work list        ; (co, _, _) <- wrapUnifierTcS ev role $ \uenv ->                        uType uenv t1 t2          -- Set  d :: (t1~t2) = Eq# co        ; setWantedEvTerm dest EvCanonical $-         evDataConApp data_con tys [Coercion co]+         evDictApp cls tys [Coercion co]        ; stopWith ev "Solved wanted lifted equality" } -  | CtGiven { ctev_evar = ev_id, ctev_loc = loc } <- ev+  | CtGiven (GivenCt { ctev_evar = ev_id }) <- ev   , [sel_id] <- classSCSelIds cls  -- Equality classes have just one superclass   = Stage $-    do { let sc_pred = classMethodInstTy sel_id tys+    do { let loc = ctEvLoc ev+             sc_pred = classMethodInstTy sel_id tys              ev_expr = EvExpr $ Var sel_id `mkTyApps` tys `App` evId ev_id        ; given_ev <- newGivenEvVar loc (sc_pred, ev_expr)-       ; startAgainWith (mkNonCanonical given_ev) }+       ; startAgainWith (mkNonCanonical $ CtGiven given_ev) }   | otherwise   = pprPanic "solveEqualityDict" (ppr cls) @@ -480,30 +531,24 @@         case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) }  ** NB: It is important to emphasize that all this is purely an optimization:-** exactly the same programs should typecheck with or without this-** procedure.--Solving fully-~~~~~~~~~~~~~-There is a reason why the solver does not simply try to solve such-constraints with top-level instances. If the solver finds a relevant-instance declaration in scope, that instance may require a context-that can't be solved for. A good example of this is:--    f :: Ord [a] => ...-    f x = ..Need Eq [a]...+** exactly the same programs should typecheck with or without this procedure. -If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would-be left with the obligation to solve the constraint Eq a, which we cannot. So we-must be conservative in our attempt to use an instance declaration to solve the-[W] constraint we're interested in.+Consider+       f :: Ord [a] => ...+       f x = ..Need Eq [a]...+We could use the Eq [a] superclass of the Ord [a], or we could use the top-level+instance `Eq a => Eq [a]`.   But if we did the latter we'd be stuck with an+insoluble constraint (Eq a). -Our rule is that we try to solve all of the instance's subgoals-recursively all at once. Precisely: We only attempt to solve-constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci-are themselves class constraints of the form `C1', ... Cm' => C' t1'-... tn'` and we only succeed if the entire tree of constraints is-solvable from instances.+-----------------------------------+So the ShortCutSolving plan is this:+   If we could solve a constraint from a local Given,+       try first to /completely/ solve the constraint+       using only top-level instances,+       /without/ using any local Givens.+   - If that succeeds, use it+   - If not, use the local Given+-----------------------------------  An example that succeeds: @@ -529,7 +574,8 @@     f :: C [a] b => b -> Bool     f x = m x == [] -Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces:+Which, because solving `Eq [a]` demands `Eq a` which we cannot solve. so short-cut+solving fails and we use the superclass of C:      f :: forall a b. C [a] b => b -> Bool     f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) ->@@ -539,24 +585,57 @@           (m @ [a] @ b $dC eta)           (GHC.Types.[] @ a) -Note [Shortcut solving: type families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have (#13943)-  class Take (n :: Nat) where ...-  instance {-# OVERLAPPING #-}                    Take 0 where ..-  instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..+The moving parts are relatively simple: -And we have [W] Take 3.  That only matches one instance so we get-[W] Take (3-1).  Really we should now rewrite to reduce the (3-1) to 2, and-so on -- but that is reproducing yet more of the solver.  Sigh.  For now,-we just give up (remember all this is just an optimisation).+* To attempt to solve the constraint completely, we just recursively+  call the constraint solver. See the use of `tryShortCutTcS` in+  `tcShortCutSolver`. -But we must not just naively try to lookup (Take (3-1)) in the-InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a-unique match on the (Take n) instance.  That leads immediately to an-infinite loop.  Hence the check that 'preds' have no type families-(isTyFamFree).+* When this attempted recursive solving, in `tryShortCutTcS`, we+  - start with an empty inert set: no Givens and no Wanteds+  - set a special mode  `TcSShortCut`, which signals that we are trying to solve+    using only top-level instances. +* When in TcSShortCut mode, since there are no Givens we can short-circuit;+  these are all just optimisations:+      - `tryInertDicts`+      - `GHC.Tc.Solver.Monad.lookupInertDict`+      - `noMatchableGivenDicts`+      - `matchLocalInst`+      - `GHC.Tc.Solver.Solve.runTcPluginsWanted`++* In `GHC.Tc.Solver.Instance.Class.matchInstEnv`: when short-cut solving,+  don't pick overlappable top-level instances++Some wrinkles:++(SCS1) Note [Shortcut solving: incoherence]++(SCS2) The short-cut solver just uses the solver recursively, so we get its+  full power:++    * We need to be able to handle recursive super classes. The+      solved_dicts state  ensures that we remember what we have already+      tried to solve to avoid looping.++    * As #15164 showed, it can be important to exploit sharing between+      goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;+      and to solve G2 we may need H. If we don't spot this sharing we may+      solve H twice; and if this pattern repeats we may get exponentially bad+      behaviour.++    * Suppose we have (#13943)+          class Take (n :: Nat) where ...+          instance {-# OVERLAPPING #-}                    Take 0 where ..+          instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..++      And we have [W] Take 3.  That only matches one instance so we get+      [W] Take (3-1).  Then we should reduce the (3-1) to 2, and continue.++(SCS3) When doing short-cut solving we can (and should) inherit the `solved_dicts`+    of the caller (#15164).  You might worry about having a solved-dict that uses+    a Given -- but that too will have been subject to short-cut solving so it's fine.+ Note [Shortcut solving: incoherence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This optimization relies on coherence of dictionaries to be correct. When we@@ -621,38 +700,7 @@ IncoherentInstances is `1`. If we were to do the optimization, the output of `main` would be `2`. -Note [Shortcut try_solve_from_instance]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The workhorse of the short-cut solver is-    try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)-                            -> CtEvidence       -- Solve this-                            -> MaybeT TcS (EvBindMap, DictMap CtEvidence)-Note that: -* The CtEvidence is the goal to be solved--* The MaybeT manages early failure if we find a subgoal that-  cannot be solved from instances.--* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional-  state that allows try_solve_from_instance to augment the evidence-  bindings and inert_solved_dicts as it goes.--  If it succeeds, we commit all these bindings and solved dicts to the-  main TcS InertSet.  If not, we abandon it all entirely.--Passing along the solved_dicts important for two reasons:--* We need to be able to handle recursive super classes. The-  solved_dicts state  ensures that we remember what we have already-  tried to solve to avoid looping.--* As #15164 showed, it can be important to exploit sharing between-  goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;-  and to solve G2 we may need H. If we don't spot this sharing we may-  solve H twice; and if this pattern repeats we may get exponentially bad-  behaviour.- Note [No Given/Given fundeps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do not create constraints from:@@ -723,147 +771,75 @@  try_inert_dicts :: InertCans -> DictCt -> TcS (StopOrContinue ()) try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_cls = cls, di_tys = tys })-  | Just dict_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys+  | Just dict_i <- lookupInertDict inerts cls tys   , let ev_i  = dictCtEvidence dict_i         loc_i = ctEvLoc ev_i         loc_w = ctEvLoc ev_w   = -- There is a matching dictionary in the inert set-    do { -- First to try to solve it /completely/ from top level instances+    do { -- For a Wanted, first to try to solve it /completely/ from top level instances          -- See Note [Shortcut solving]-         dflags <- getDynFlags-       ; short_cut_worked <- shortCutSolver dflags ev_w ev_i-       ; if short_cut_worked-         then stopWith ev_w "interactDict/solved from instance"+       ; short_cut_worked <- tryShortCutSolver (isGiven ev_i) dict_w -         -- Next see if we are in "loopy-superclass" land.  If so,-         -- we don't want to replace the (Given) inert with the-         -- (Wanted) work-item, or vice versa; we want to hang on-         -- to both, and try to solve the work-item via an instance.-         -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance-         else if prohibitedSuperClassSolve loc_i loc_w-         then continueWith ()-         else-    do { -- The short-cut solver didn't fire, and loopy superclasses-         -- are dealt with, so we can either solve-         -- the inert from the work-item or vice-versa.-       ; case solveOneFromTheOther (CDictCan dict_i) (CDictCan dict_w) of-           KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr dict_w)-                           ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i)-                           ; return $ Stop ev_w (text "Dict equal" <+> ppr dict_w) }-           KeepWork  -> do { traceTcS "lookupInertDict:KeepWork" (ppr dict_w)-                           ; setEvBindIfWanted ev_i EvCanonical (ctEvTerm ev_w)-                           ; updInertCans (updDicts $ delDict dict_w)-                           ; continueWith () } } }+       ; if | short_cut_worked+            -> stopWith ev_w "shortCutSolver worked(1)" +            -- Next see if we are in "loopy-superclass" land.  If so,+            -- we don't want to replace the (Given) inert with the+            -- (Wanted) work-item, or vice versa; we want to hang on+            -- to both, and try to solve the work-item via an instance.+            -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+            | prohibitedSuperClassSolve loc_i loc_w+            -> continueWith ()++            | otherwise -- We can either solve the inert from the work-item or vice-versa.+            -> case solveOneFromTheOther (CDictCan dict_i) (CDictCan dict_w) of+                 KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr dict_w)+                                 ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i)+                                 ; return $ Stop ev_w (text "Dict equal" <+> ppr dict_w) }+                 KeepWork  -> do { traceTcS "lookupInertDict:KeepWork" (ppr dict_w)+                                 ; setEvBindIfWanted ev_i EvCanonical (ctEvTerm ev_w)+                                 ; updInertCans (updDicts $ delDict dict_w)+                                 ; continueWith () } }+   | otherwise   = do { traceTcS "tryInertDicts:no" (ppr dict_w $$ ppr cls <+> ppr tys)        ; continueWith () }  -- See Note [Shortcut solving]-shortCutSolver :: DynFlags-               -> CtEvidence -- Work item-               -> CtEvidence -- Inert we want to try to replace-               -> TcS Bool   -- True <=> success-shortCutSolver dflags ev_w ev_i-  | isWanted ev_w-  , isGiven ev_i-    -- We are about to solve a [W] constraint from a [G] constraint. We take-    -- a moment to see if we can get a better solution using an instance.-    -- Note that we only do this for the sake of performance. Exactly the same-    -- programs should typecheck regardless of whether we take this step or-    -- not. See Note [Shortcut solving]--  , not (isIPLikePred (ctEvPred ev_w))   -- Not for implicit parameters (#18627)--  , not (xopt LangExt.IncoherentInstances dflags)-    -- If IncoherentInstances is on then we cannot rely on coherence of proofs-    -- in order to justify this optimization: The proof provided by the-    -- [G] constraint's superclass may be different from the top-level proof.-    -- See Note [Shortcut solving: incoherence]--  , gopt Opt_SolveConstantDicts dflags-    -- Enabled by the -fsolve-constant-dicts flag--  = do { ev_binds_var <- getTcEvBindsVar-       ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $-                     getTcEvBindsMap ev_binds_var-       ; solved_dicts <- getSolvedDicts--       ; mb_stuff <- runMaybeT $-                     try_solve_from_instance (ev_binds, solved_dicts) ev_w--       ; case mb_stuff of-           Nothing -> return False-           Just (ev_binds', solved_dicts')-              -> do { setTcEvBindsMap ev_binds_var ev_binds'-                    ; setSolvedDicts solved_dicts'-                    ; return True } }--  | otherwise+tryShortCutSolver :: Bool       -- True <=> try the short-cut solver; False <=> don't+                  -> DictCt     -- Work item+                  -> TcS Bool   -- True <=> success+-- We are about to solve a [W] constraint from a [G] constraint. We take+-- a moment to see if we can get a better solution using an instance.+-- Note that we only do this for the sake of performance. Exactly the same+-- programs should typecheck regardless of whether we take this step or+-- not. See Note [Shortcut solving]+tryShortCutSolver try_short_cut dict_w@(DictCt { di_ev = ev_w })+  | not try_short_cut   = return False-  where-    -- This `CtLoc` is used only to check the well-staged condition of any-    -- candidate DFun. Our subgoals all have the same stage as our root-    -- [W] constraint so it is safe to use this while solving them.-    loc_w = ctEvLoc ev_w--    try_solve_from_instance   -- See Note [Shortcut try_solve_from_instance]-      :: (EvBindMap, DictMap DictCt) -> CtEvidence-      -> MaybeT TcS (EvBindMap, DictMap DictCt)-    try_solve_from_instance (ev_binds, solved_dicts) ev-      | let pred = ctEvPred ev-      , ClassPred cls tys <- classifyPredType pred-      = do { inst_res <- lift $ matchGlobalInst dflags True cls tys loc_w-           ; lift $ warn_custom_warn_instance inst_res loc_w-                 -- See Note [Implementation of deprecated instances]-           ; case inst_res of-               OneInst { cir_new_theta   = preds-                       , cir_mk_ev       = mk_ev-                       , cir_canonical   = canonical-                       , cir_what        = what }-                 | safeOverlap what-                 , all isTyFamFree preds  -- Note [Shortcut solving: type families]-                 -> do { let dict_ct = DictCt { di_ev = ev, di_cls = cls-                                              , di_tys = tys, di_pend_sc = doNotExpand }-                             solved_dicts' = addSolvedDict dict_ct solved_dicts-                             -- solved_dicts': it is important that we add our goal-                             -- to the cache before we solve! Otherwise we may end-                             -- up in a loop while solving recursive dictionaries.--                       ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)-                       ; loc' <- lift $ checkInstanceOK (ctEvLoc ev) what pred-                       ; lift $ checkReductionDepth loc' pred-+  | otherwise+  = do { dflags <- getDynFlags+       ; if | CtWanted (WantedCt { ctev_pred = pred_w }) <- ev_w -                       ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds-                                  -- Emit work for subgoals but use our local cache-                                  -- so we can solve recursive dictionaries.+            , not (couldBeIPLike pred_w)   -- Not for implicit parameters (#18627) -                       ; let ev_tm     = mk_ev (map getEvExpr evc_vs)-                             ev_binds' = extendEvBinds ev_binds $-                                         mkWantedEvBind (ctEvEvId ev) canonical ev_tm+            , not (xopt LangExt.IncoherentInstances dflags)+              -- If IncoherentInstances is on then we cannot rely on coherence of proofs+              -- in order to justify this optimization: The proof provided by the+              -- [G] constraint's superclass may be different from the top-level proof.+              -- See Note [Shortcut solving: incoherence] -                       ; foldlM try_solve_from_instance (ev_binds', solved_dicts') $-                         freshGoals evc_vs }+            , gopt Opt_SolveConstantDicts dflags+              -- Enabled by the -fsolve-constant-dicts flag -               _ -> mzero }+            -> tryShortCutTcS $  -- tryTcS tries to completely solve some contraints+               do { residual <- solveSimpleWanteds (unitBag (CDictCan dict_w))+                  ; return (isEmptyWC residual) } -      | otherwise-      = mzero+            | otherwise+            -> return False }  -    -- Use a local cache of solved dicts while emitting EvVars for new work-    -- We bail out of the entire computation if we need to emit an EvVar for-    -- a subgoal that isn't a ClassPred.-    new_wanted_cached :: CtEvidence -> CtLoc-                      -> DictMap DictCt -> TcPredType -> MaybeT TcS MaybeNew-    new_wanted_cached ev_w loc cache pty-      | ClassPred cls tys <- classifyPredType pty-      = lift $ case findDict cache loc_w cls tys of-          Just dict_ct -> return $ Cached (ctEvExpr (dictCtEvidence dict_ct))-          Nothing      -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty-      | otherwise = mzero- {- ******************************************************************* *                                                                    *          Top-level reaction for class constraints (CDictCan)@@ -883,7 +859,7 @@   = continueWith ()      -- See Note [No Given/Given fundeps] -  | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached+  | Just solved_ev <- lookupSolvedDict inerts cls xis   -- Cached   = do { setEvBindIfWanted ev EvCanonical (ctEvTerm solved_ev)        ; stopWith ev "Dict/Top (cached)" } @@ -892,11 +868,14 @@         ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc         ; case lkup_res of                OneInst { cir_what = what }-                  -> do { insertSafeOverlapFailureTcS what work_item-                        ; updSolvedDicts what work_item-                        ; chooseInstance ev lkup_res }-               _  -> -- NoInstance or NotSure-                     -- We didn't solve it; so try functional dependencies+                  -> do { let is_local_given = case what of { LocalInstance -> True; _ -> False }+                        ; take_shortcut <- tryShortCutSolver is_local_given work_item+                        ; if take_shortcut+                          then stopWith ev "shortCutSolver worked(2)"+                          else do { insertSafeOverlapFailureTcS what work_item+                                  ; updSolvedDicts what work_item+                                  ; chooseInstance ev lkup_res } }+               _  -> -- NoInstance or NotSure: we didn't solve it                      continueWith () }    where      dict_loc = ctEvLoc ev@@ -914,7 +893,7 @@                     (ppr work_item)        ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta        ; setEvBindIfWanted work_item canonical (mk_ev (map getEvExpr evc_vars))-       ; emitWorkNC (freshGoals evc_vars)+       ; emitWorkNC (map CtWanted $ freshGoals evc_vars)        ; stopWith work_item "Dict/Top (solved wanted)" }   where      pred = ctEvPred work_item@@ -929,7 +908,7 @@ -- Returns the CtLoc to used for sub-goals -- Probably also want to call checkReductionDepth checkInstanceOK loc what pred-  = do { checkWellStagedDFun loc what pred+  = do { checkWellLevelledDFun loc what pred        ; return deeper_loc }   where      deeper_loc = zap_origin (bumpCtLocDepth loc)@@ -977,7 +956,7 @@                    ; return local_res }             NoInstance  -- No local instances, so try global ones-              -> do { global_res <- matchGlobalInst dflags False clas tys loc+              -> do { global_res <- matchGlobalInst dflags clas tys loc                     ; warn_custom_warn_instance global_res loc                           -- See Note [Implementation of deprecated instances]                     ; traceTcS "} matchClassInst global result" $ ppr global_res@@ -985,6 +964,25 @@   where     pred = mkClassPred clas tys +-- | Returns True iff there are no Given constraints that might,+-- potentially, match the given class constraint. 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.Dict+noMatchableGivenDicts :: InertSet -> CtLoc -> Class -> [TcType] -> Bool+noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys+  = not $ anyBag matchable_given $+    findDictsByClass (inert_dicts inert_cans) clas+  where+    pred_w = mkClassPred clas tys++    matchable_given :: DictCt -> Bool+    matchable_given (DictCt { di_ev = ev })+      | CtGiven (GivenCt { ctev_loc = loc_g, ctev_pred = pred_g }) <- ev+      = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w++      | otherwise+      = False+ {- Note [Implementation of deprecated instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This note describes the implementation of the deprecated instances GHC proposal@@ -1076,7 +1074,7 @@      - natural numbers      - Typeable -* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet.+* See also Note [What might equal later?] in GHC.Tc.Utils.Unify  * The given-overlap problem is arguably not easy to appear in practice   due to our aggressive prioritization of equality solving over other@@ -1145,15 +1143,18 @@ matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult -- Look up the predicate in Given quantified constraints, -- which are effectively just local instance declarations.-matchLocalInst pred loc-  = do { inerts@(IS { inert_cans = ics }) <- getInertSet-       ; case match_local_inst inerts (inert_insts ics) of-          { ([], []) -> do { traceTcS "No local instance for" (ppr pred)-                           ; return NoInstance }-          ; (matches, unifs) ->-    do { matches <- mapM mk_instDFun matches-       ; unifs   <- mapM mk_instDFun unifs+matchLocalInst body_pred loc+  = do { -- Look in the inert set for a matching Given quantified constraint+         inerts@(IS { inert_cans = ics }) <- getInertSet+       ; case match_local_inst inerts (inert_qcis ics) of+            { ([], []) -> do { traceTcS "No local instance for" (ppr body_pred)+                             ; return NoInstance }+            ; (matches, unifs) ->++    do { -- Find the best match          -- See Note [Use only the best matching quantified constraint]+         matches <- mapM mk_instDFun matches+       ; unifs   <- mapM mk_instDFun unifs        ; case dominatingMatch matches of           { Just (dfun_id, tys, theta)             | all ((theta `impliedBySCs`) . thdOf3) unifs@@ -1163,7 +1164,7 @@                                       , cir_canonical   = EvCanonical                                       , cir_what        = LocalInstance }                ; traceTcS "Best local instance found:" $-                  vcat [ text "pred:" <+> ppr pred+                  vcat [ text "body_pred:" <+> ppr body_pred                        , text "result:" <+> ppr result                        , text "matches:" <+> ppr matches                        , text "unifs:" <+> ppr unifs ]@@ -1171,13 +1172,13 @@            ; mb_best ->             do { traceTcS "Multiple local instances; not committing to any"-                  $ vcat [ text "pred:" <+> ppr pred+                  $ vcat [ text "body_pred:" <+> ppr body_pred                          , text "matches:" <+> ppr matches                          , text "unifs:" <+> ppr unifs                          , text "best_match:" <+> ppr mb_best ]                ; return NotSure }}}}}   where-    pred_tv_set = tyCoVarsOfType pred+    body_pred_tv_set = tyCoVarsOfType body_pred      mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun     mk_instDFun (ev, tys) =@@ -1193,18 +1194,21 @@     match_local_inst _inerts []       = ([], [])     match_local_inst inerts (qci@(QCI { qci_tvs  = qtvs-                                      , qci_pred = qpred+                                      , qci_body = qbody                                       , qci_ev   = qev })-                            :qcis)-      | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)+                            : qcis)+      | isWanted qev    -- Skip Wanteds+      = match_local_inst inerts qcis++      | let in_scope = mkInScopeSet (qtv_set `unionVarSet` body_pred_tv_set)       , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)-                                        emptyTvSubstEnv qpred pred+                                        emptyTvSubstEnv qbody body_pred       , let match = (qev, map (lookupVarEnv tv_subst) qtvs)       = (match:matches, unifs)        | otherwise-      = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred))-                  (ppr qci $$ ppr pred)+      = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType body_pred))+                  (ppr qci $$ ppr body_pred)             -- ASSERT: unification relies on the             -- quantified variables being fresh         (matches, this_unif `combine` unifs)@@ -1213,7 +1217,7 @@         qtv_set = mkVarSet qtvs         (matches, unifs) = match_local_inst inerts qcis         this_unif-          | Just subst <- mightEqualLater inerts qpred qloc pred loc+          | Just subst <- mightEqualLater inerts qbody qloc body_pred loc           = Just (qev, map  (lookupTyVar subst) qtvs)           | otherwise           = Nothing@@ -1758,7 +1762,7 @@  1. Eagerly generate superclasses for given (but not wanted)    constraints; see Note [Eagerly expand given superclasses].-   This is done using mkStrictSuperClasses in canClassNC, when+   This is done using mkStrictSuperClasses in canDictCt, when    we take a non-canonical Given constraint and cannonicalise it.     However stop if you encounter the same class twice.  That is,@@ -1770,7 +1774,7 @@    solveSimpleWanteds; Note [Danger of adding superclasses during solving]     However, /do/ continue to eagerly expand superclasses for new /given/-   /non-canonical/ constraints (canClassNC does this).  As #12175+   /non-canonical/ constraints (canDictCt does this).  As #12175    showed, a type-family application can expand to a class constraint,    and we want to see its superclasses for just the same reason as    Note [Eagerly expand given superclasses].@@ -1826,7 +1830,7 @@ our strategy.  Consider   f :: C a => a -> Bool   f x = x==x-Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses+Then canDictCt gets the [G] d1: C a constraint, and eager emits superclasses G] d2: D a, [G] d3: C a (psc).  (The "psc" means it has its cc_pend_sc has pending expansion fuel.) When processing d3 we find a match with d1 in the inert set, and we always@@ -1863,11 +1867,11 @@  So we may need to do a little work on the givens to expose the class that has the superclasses.  That's why the superclass-expansion for Givens happens in canClassNC.+expansion for Givens happens in canDictCt.  This same scenario happens with quantified constraints, whose superclasses are also eagerly expanded. Test case: typecheck/should_compile/T16502b-These are handled in canForAllNC, analogously to canClassNC.+These are handled in canForAllNC, analogously to canDictCt.  Note [Why adding superclasses can help] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1955,10 +1959,10 @@  More generally, if we are expanding the superclasses of   g0 :: forall tvs. theta => cls tys-and find a superclass constraint+and find a superclass constraint (itself perhaps a quantified constraint)   forall sc_tvs. sc_theta => sc_inner_pred we must have a selector-  sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred+  sel_id :: forall cls_tvs. cls cls_tvs => forall sc_tvs. sc_theta => sc_inner_pred and thus build   g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred   g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids.@@ -1971,7 +1975,13 @@   g_sc = /\ tvs. /\ sc_tvs. \ theta_ids.          sel_id tys (g0 tvs theta_ids) sc_tvs -  -}+(NQCS1) Common case.  If theta_ids[] we get just+     g_sc = /\ tvs. /\sc_tvs. sel_id tys (g0 tvs) sc_tvs+  and can eta-reduce even more to+     g_sc = /\ tvs. sel_id tys (g0 tvs)+  and if tvs=[] we get the straight superclass selection+     g_sc = sel_id tys g0+-}  makeSuperClasses :: [Ct] -> TcS [Ct] -- Returns strict superclasses, transitively, see Note [The superclass story]@@ -1991,10 +2001,9 @@     go (CDictCan (DictCt { di_ev = ev, di_cls = cls, di_tys = tys, di_pend_sc = fuel }))       = assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always         mkStrictSuperClasses fuel ev [] [] cls tys-    go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev, qci_pend_sc = fuel }))-      = assertPpr (isClassPred pred) (ppr pred) $  -- The cts should all have-                                                   -- class pred heads-        assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always+    go (CQuantCan (QCI { qci_body = body_pred, qci_ev = ev, qci_pend_sc = fuel }))+      = assertPpr (isClassPred body_pred) (ppr body_pred) $ -- The cts should all have class pred heads+        assertFuelPreconditionStrict fuel $                 -- fuel needs to be more than 0, always         mkStrictSuperClasses fuel ev tvs theta cls tys       where         (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)@@ -2022,16 +2031,15 @@ -- The caller of this function is supposed to perform fuel book keeping -- Precondition: fuel >= 0 mk_strict_superclasses _ _ _ _ _ cls _-  | isEqualityClass cls+  | isEqualityClass cls  -- See (EQC1) in Note [Solving equality classes]   = return [] -mk_strict_superclasses fuel rec_clss-                       ev@(CtGiven { ctev_evar = evar, ctev_loc = loc })-                       tvs theta cls tys+mk_strict_superclasses fuel rec_clss ev@(CtGiven (GivenCt { ctev_evar = evar })) tvs theta cls tys   = -- Given case     do { traceTcS "mk_strict" (ppr ev $$ ppr (ctLocOrigin loc))        ; concatMapM do_one_given (classSCSelIds cls) }   where+    loc  = ctEvLoc ev     dict_ids  = mkTemplateLocals theta     this_size = pSizeClassPred cls tys @@ -2046,14 +2054,14 @@       = do { given_ev <- newGivenEvVar sc_loc $                          mk_given_desc sel_id sc_pred            ; assertFuelPrecondition fuel $-             mk_superclasses fuel rec_clss given_ev tvs theta sc_pred }+             mk_superclasses fuel rec_clss (CtGiven given_ev) tvs theta sc_pred }       where         sc_pred = classMethodInstTy sel_id tys        -- See Note [Nested quantified constraint superclasses]     mk_given_desc :: Id -> PredType -> (PredType, EvTerm)     mk_given_desc sel_id sc_pred-      = (swizzled_pred, swizzled_evterm)+      = (swizzled_pred, EvExpr swizzled_evterm)       where         (sc_tvs, sc_rho)          = splitForAllTyCoVars sc_pred         (sc_theta, sc_inner_pred) = splitFunTys sc_rho@@ -2062,17 +2070,18 @@         all_theta     = theta `chkAppend` (map scaledThing sc_theta)         swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred -        -- evar :: forall tvs. theta => cls tys+        -- evar   :: forall tvs. theta => cls tys         -- sel_id :: forall cls_tvs. cls cls_tvs-        --                        -> forall sc_tvs. sc_theta => sc_inner_pred+        --                        => forall sc_tvs. sc_theta => sc_inner_pred         -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred-        swizzled_evterm = EvExpr $-          mkLams all_tvs $-          mkLams dict_ids $-          Var sel_id-            `mkTyApps` tys-            `App` (evId evar `mkVarApps` (tvs ++ dict_ids))-            `mkVarApps` sc_tvs+        swizzled_evterm+          | null tvs, null theta -- See wrinkle (NQCS1)+          = Var sel_id `mkTyApps` tys `App` evId evar+          | otherwise+          = mkLams all_tvs $ mkLams dict_ids $+            Var sel_id `mkTyApps` tys+                       `App` (evId evar `mkVarApps` (tvs ++ dict_ids))+                       `mkVarApps` sc_tvs      sc_loc | isCTupleClass cls = loc            | otherwise         = loc { ctl_origin = mk_sc_origin (ctLocOrigin loc) }@@ -2102,7 +2111,9 @@     newly_blocked _                      = False  -- Wanted case-mk_strict_superclasses fuel rec_clss ev tvs theta cls tys+mk_strict_superclasses fuel rec_clss+  (CtWanted (WantedCt { ctev_pred = pty, ctev_loc = loc0, ctev_rewriters = rws }))+  tvs theta cls tys   | all noFreeVarsOfType tys   = return [] -- Wanteds with no variables yield no superclass constraints.               -- See Note [Improvement from Ground Wanteds]@@ -2112,12 +2123,12 @@   = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $     concatMapM do_one (immSuperClasses cls tys)   where-    loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev)+    loc = loc0 `updateCtLocOrigin` WantedSuperclassOrigin pty      do_one sc_pred       = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)-           ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred-           ; mk_superclasses fuel rec_clss sc_ev [] [] sc_pred }+           ; sc_ev <- newWantedNC loc rws sc_pred+           ; mk_superclasses fuel rec_clss (CtWanted sc_ev) [] [] sc_pred }  {- Note [Improvement from Ground Wanteds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2178,7 +2189,8 @@                     -- NB: If there is a loop, we cut off, so we have not                     --     added the superclasses, hence cc_pend_sc = fuel                     | otherwise-                    = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys+                    = CQuantCan (QCI { qci_tvs = tvs, qci_theta = theta+                                     , qci_body = mkClassPred cls tys                                      , qci_ev = ev, qci_pend_sc = fuel })  @@ -2208,8 +2220,7 @@ dictionary "functions" that are unboxed.  Actually it does just about work, but the simplifier ends up with stuff like    case (/\a. eq_sel d) of df -> ...(df @Int)...-and fails to simplify that any further.  And it doesn't satisfy-isPredTy any more.+and fails to simplify that any further.  So for now we simply decline to take superclasses in the quantified case.  Instead we have a special case in GHC.Tc.Solver.Equality.tryQCsEqCt
compiler/GHC/Tc/Solver/Equality.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}  module GHC.Tc.Solver.Equality(@@ -8,6 +10,8 @@  import GHC.Prelude +import {-# SOURCE #-} GHC.Tc.Solver.Solve( trySolveImplication )+ import GHC.Tc.Solver.Irred( solveIrred ) import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) import GHC.Tc.Solver.Rewrite@@ -33,7 +37,7 @@ import GHC.Core.Coercion import GHC.Core.Coercion.Axiom import GHC.Core.Reduction-import GHC.Core.Unify( tcUnifyTyWithTFs )+import GHC.Core.Unify( tcUnifyTyForInjectivity ) import GHC.Core.FamInstEnv ( FamInstEnvs, FamInst(..), apartnessCheck                            , lookupFamInstEnvByTyCon ) import GHC.Core@@ -360,11 +364,13 @@  -- Then, get rid of casts can_eq_nc rewritten rdr_env envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2-  | isNothing (canEqLHS_maybe ty2)  -- See (EIK3) in Note [Equalities with incompatible kinds]-  = canEqCast rewritten rdr_env envs ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2+  | isNothing (canEqLHS_maybe ty2)+  = -- See (EIK3) in Note [Equalities with heterogeneous kinds]+    canEqCast rewritten rdr_env envs ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _-  | isNothing (canEqLHS_maybe ty1)  -- See (EIK3) in Note [Equalities with incompatible kinds]-  = canEqCast rewritten rdr_env envs ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1+  | isNothing (canEqLHS_maybe ty1)+  = -- See (EIK3) in Note [Equalities with heterogeneous kinds]+    canEqCast rewritten rdr_env envs ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1  ---------------------- -- Otherwise try to decompose@@ -486,7 +492,7 @@ -- See Note [Solving forall equalities]  can_eq_nc_forall ev eq_rel s1 s2- | CtWanted { ctev_dest = orig_dest } <- ev+ | CtWanted (WantedCt { ctev_dest = orig_dest, ctev_loc = loc }) <- ev  = do { let (bndrs1, phi1, bndrs2, phi2) = split_foralls s1 s2             flags1 = binderFlags bndrs1             flags2 = binderFlags bndrs2@@ -497,11 +503,11 @@                           , ppr flags1, ppr flags2 ]                 ; canEqHardFailure ev s1 s2 } -        else do {-        traceTcS "Creating implication for polytype equality" (ppr ev)-      ; let free_tvs     = tyCoVarsOfTypes [s1,s2]-            empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs-      ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1)+        else+   do { let free_tvs       = tyCoVarsOfTypes [s1,s2]+            empty_subst1   = mkEmptySubst $ mkInScopeSet free_tvs+            skol_info_anon = UnifyForAllSkol phi1+      ; skol_info <- mkSkolemInfo skol_info_anon       ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $                               binderVars bndrs1 @@ -538,18 +544,36 @@              go _ _ _ _ _ = panic "can_eq_nc_forall"  -- case (s:ss) [] -            init_subst2 = mkEmptySubst (getSubstInScope subst1)+            init_subst2 = mkEmptySubst (substInScopeSet subst1) +      ; traceTcS "Generating wanteds" (ppr s1 $$ ppr s2)+       -- Generate the constraints that live in the body of the implication       -- See (SF5) in Note [Solving forall equalities]       ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info)   $                                     unifyForAllBody ev (eqRelRole eq_rel) $ \uenv ->                                     go uenv skol_tvs init_subst2 bndrs1 bndrs2 -      ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds+      -- Solve the implication right away, using `trySolveImplication`+      -- See (SF6) in Note [Solving forall equalities]+      ; traceTcS "Trying to solve the implication" (ppr s1 $$ ppr s2 $$ ppr wanteds)+      ; ev_binds_var <- newNoTcEvBinds+      ; solved <- trySolveImplication $+                  (implicationPrototype (ctLocEnv loc))+                      { ic_tclvl = lvl+                      , ic_binds = ev_binds_var+                      , ic_info  = skol_info_anon+                      , ic_warn_inaccessible = False+                      , ic_skols = skol_tvs+                      , ic_given = []+                      , ic_wanted = emptyWC { wc_simple = wanteds } } -      ; setWantedEq orig_dest all_co-      ; stopWith ev "Deferred polytype equality" } }+      ; if solved+        then do { zonked_all_co <- zonkCo all_co+                      -- ToDo: explain this zonk+                ; setWantedEq orig_dest zonked_all_co+                ; stopWith ev "Polytype equality: solved" }+        else canEqSoftFailure IrredShapeReason ev s1 s2 } }   | otherwise  = do { traceTcS "Omitting decomposition of given polytype equality" $@@ -574,7 +598,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To solve an equality between foralls    [W] (forall a. t1) ~ (forall b. t2)-the basic plan is simple: just create the implication constraint+the basic plan is simple: use `trySolveImplication` to solve the+implication constraint    [W] forall a. { t1 ~ (t2[a/b]) }  The evidence we produce is a ForAllCo; see the typing rule for@@ -619,6 +644,21 @@    especially Refl ones.  We use the `unifyForAllBody` wrapper for `uType`,    because we want to /gather/ the equality constraint (to put in the implication)    rather than /emit/ them into the monad, as `wrapUnifierTcS` does.++(SF6) We solve the implication on the spot, using `trySolveImplication`.  In+   the past we instead generated an `Implication` to be solved later.  Nice in+   some ways but it added complexity:+      - We needed a `wl_implics` field of `WorkList` to collect+        these emitted implications+      - The types of `solveSimpleWanteds` and friends were more complicated+      - Trickily, an `EvFun` had to contain an `EvBindsVar` ref-cell, which made+        `evVarsOfTerm` harder.  Now an `EvFun` just contains the bindings.+   The disadvantage of solve-on-the-spot is that if we fail we are simply+   left with an unsolved (forall a. blah) ~ (forall b. blah), and it may+   not be clear /why/ we couldn't solve it.  But on balance the error messages+   improve: it is easier to undertand that+       (forall a. a->a) ~ (forall b. b->Int)+   is insoluble than it is to understand a message about matching `a` with `Int`. -}  {- Note [Unwrap newtypes first]@@ -771,7 +811,7 @@ -- to an irreducible constraint; see typecheck/should_compile/T10494 -- See Note [Decomposing AppTy equalities] can_eq_app ev s1 t1 s2 t2-  | CtWanted { ctev_dest = dest } <- ev+  | CtWanted (WantedCt { ctev_dest = dest }) <- ev   = do { traceTcS "can_eq_app" (vcat [ text "s1:" <+> ppr s1, text "t1:" <+> ppr t1                                      , text "s2:" <+> ppr s2, text "t2:" <+> ppr t2                                      , text "vis:" <+> ppr (isNextArgVisible s1) ])@@ -794,7 +834,7 @@   | s1k `mismatches` s2k   = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) -  | CtGiven { ctev_evar = evar } <- ev+  | CtGiven (GivenCt { ctev_evar = evar }) <- ev   = do { let co   = mkCoVarCo evar              co_s = mkLRCo CLeft  co              co_t = mkLRCo CRight co@@ -802,8 +842,8 @@                                      , evCoercion co_s )        ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2                                      , evCoercion co_t )-       ; emitWorkNC [evar_t]-       ; startAgainWith (mkNonCanonical evar_s) }+       ; emitWorkNC [CtGiven evar_t]+       ; startAgainWith (mkNonCanonical $ CtGiven evar_s) }    where     loc = ctEvLoc ev@@ -852,18 +892,26 @@   = do { inerts <- getInertSet        ; if can_decompose inerts          then canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2)-         else canEqSoftFailure ev eq_rel ty1 ty2 }+         else assert (eq_rel == ReprEq) $+              canEqSoftFailure ReprEqReason ev ty1 ty2 }    -- See Note [Skolem abstract data] in GHC.Core.Tycon   | tyConSkolem tc1 || tyConSkolem tc2   = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)        ; finishCanWithIrred AbstractTyConReason ev } -  | otherwise  -- Different TyCons-  = if both_generative -- See (TC2) and (TC3) in-                       -- Note [Canonicalising TyCon/TyCon equalities]-    then canEqHardFailure ev ty1 ty2-    else canEqSoftFailure ev eq_rel ty1 ty2+  -- Different TyCons+  | NomEq <- eq_rel+  = canEqHardFailure ev ty1 ty2++  -- Different TyCons, eq_rel = ReprEq+  -- See (TC2) and (TC3) in+  -- Note [Canonicalising TyCon/TyCon equalities]+  | both_generative+  = canEqHardFailure ev ty1 ty2++  | otherwise+  = canEqSoftFailure ReprEqReason ev ty1 ty2   where      -- See Note [Decomposing TyConApp equalities]      -- and Note [Decomposing newtype equalities]@@ -991,8 +1039,8 @@ is the same => arguments are the same, modulo the role shift. See comments on GHC.Core.TyCon.isInjectiveTyCon.  This is also the CO_NTH rule in Fig 5 of the paper, except in the paper only-newtypes are non-injective at representation role, so the rule says "H-is not a newtype".+newtypes are non-injective at representation role, so the rule says+"H is not a newtype".  Injectivity is a bit subtle:                  Nominal   Representational@@ -1050,10 +1098,10 @@   left-to-right order.  See the use of `snocBag` in `uType_defer`.  * `wrapUnifierTcS` adds the bag of deferred constraints from-  `do_unifications` to the work-list using `extendWorkListEqs`.+  `do_unifications` to the work-list using `extendWorkListChildEqs`. -* `extendWorkListEqs` and `selectWorkItem` together arrange that the-  list of constraints given to `extendWorkListEqs` is processed in+* `extendWorkListChildEqs` and `selectWorkItem` together arrange that the+  list of constraints given to `extendWorkListChildEqs` is processed in   left-to-right order.  This is not a very big deal.  It reduces the number of solver steps@@ -1119,7 +1167,7 @@   them.  This is done in can_eq_nc.  Of course, we can't unwrap if the data   constructor isn't in scope.  See Note [Unwrap newtypes first]. -* Incompleteness example (EX2): see #24887+* Incompleteness example (EX2): prioritise Nominal equalities. See #24887       data family D a       data instance D Int  = MkD1 (D Char)       data instance D Bool = MkD2 (D Char)@@ -1137,7 +1185,7 @@   CONCLUSION: prioritise nominal equalites in the work list.   See Note [Prioritise equalities] in GHC.Tc.Solver.InertSet. -* Incompleteness example (EX3): available Givens+* Incompleteness example (EX3): check available Givens       newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,       type role Nt representational  -- but the user gives it an R role anyway @@ -1155,36 +1203,41 @@   equalities that could later solve it.    But what precisely does it mean to say "any Given equalities that could-  later solve it"?--  In #22924 we had-     [G] f a ~R# a     [W] Const (f a) a ~R# Const a a-  where Const is an abstract newtype.  If we decomposed the newtype, we-  could solve.  Not-decomposing on the grounds that (f a ~R# a) might turn-  into (Const (f a) a ~R# Const a a) seems a bit silly.+  later solve it"?  It's tricky! -  In #22331 we had-     [G] N a ~R# N b   [W] N b ~R# N a-  (where N is abstract so we can't unwrap). Here we really /don't/ want to-  decompose, because the /only/ way to solve the Wanted is from that Given-  (with a Sym).+  * In #22924 we had+       [G] f a ~R# a     [W] Const (f a) a ~R# Const a a+    where Const is an abstract newtype.  If we decomposed the newtype, we+    could solve.  Not-decomposing on the grounds that (f a ~R# a) might turn+    into (Const (f a) a ~R# Const a a) seems a bit silly. -  In #22519 we had-     [G] a <= b     [W] IO Age ~R# IO Int+  * In #22331 we had+       [G] N a ~R# N b   [W] N b ~R# N a+    (where N is abstract so we can't unwrap). Here we really /don't/ want to+    decompose, because the /only/ way to solve the Wanted is from that Given+    (with a Sym). -  (where IO is abstract so we can't unwrap, and newtype Age = Int; and (<=)-  is a type-level comparison on Nats).  Here we /must/ decompose, despite the-  existence of an Irred Given, or we will simply be stuck.  (Side note: We-  flirted with deep-rewriting of newtypes (see discussion on #22519 and-  !9623) but that turned out not to solve #22924, and also makes type-  inference loop more often on recursive newtypes.)+  * In #22519 we had+       [G] a <= b     [W] IO Age ~R# IO Int -  The currently-implemented compromise is this:+    (where IO is abstract so we can't unwrap, and newtype Age = Int; and (<=)+    is a type-level comparison on Nats).  Here we /must/ decompose, despite the+    existence of an Irred Given, or we will simply be stuck.  (Side note: We+    flirted with deep-rewriting of newtypes (see discussion on #22519 and+    !9623) but that turned out not to solve #22924, and also makes type+    inference loop more often on recursive newtypes.) -    we decompose [W] N s ~R# N t unless there is a [G] N s' ~ N t'+  * In #26020 we had a /quantified/ constraint+        forall x. Coercible (N t1) (N t2)+    and (roughly) [W] N t1 ~R# N t2+    That quantified constraint can solve the Wanted, so don't decompose! -  that is, a Given Irred equality with both sides headed with N.-  See the call to noGivenNewtypeReprEqs in canTyConApp.+  The currently-implemented compromise is this:+       We decompose [W] N s ~R# N t unless there is+       - an Irred [G] N s' ~ N t'+       - a quantified [G] forall ... => N s' ~ N t'+       that is, a Given equality with both sides headed with N.+  See the call to `noGivenNewtypeReprEqs` in `canTyConApp`.    This is not perfect.  In principle a Given like [G] (a b) ~ (c d), or   even just [G] c, could later turn into N s ~ N t.  But since the free@@ -1195,7 +1248,7 @@   un-expanded equality superclasses; but only in some very obscure   recursive-superclass situations. -   Yet another approach (!) is desribed in+   Yet another approach (!) is described in    Note [Decomposing newtypes a bit more aggressively].  Remember: decomposing Wanteds is always /sound/. This Note is@@ -1344,19 +1397,18 @@     do { traceTcS "canDecomposableTyConAppOK"                   (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)        ; case ev of-           CtWanted { ctev_dest = dest }+           CtWanted (WantedCt { ctev_dest = dest })              -- new_locs and tc_roles are both infinite, so we are              -- guaranteed that cos has the same length as tys1 and tys2              -- See Note [Fast path when decomposing TyConApps]              -> do { (co, _, _) <- wrapUnifierTcS ev role $ \uenv ->                         do { cos <- zipWith4M (u_arg uenv) new_locs tc_roles tys1 tys2                                     -- zipWith4M: see Note [Work-list ordering]-                                    -- in GHC.Tc.Solved.Equality                            ; return (mkTyConAppCo role tc cos) }                    ; setWantedEq dest co } -           CtGiven { ctev_evar = evar }-             | let pred_ty = mkPrimEqPredRole (eqRelRole eq_rel) ty1 ty2+           CtGiven (GivenCt { ctev_evar = evar })+             | let pred_ty = mkEqPred eq_rel ty1 ty2                    ev_co   = mkCoVarCo (setVarType evar pred_ty)                    -- setVarType: satisfy Note [mkSelCo precondition] in Coercion.hs                    -- Remember: ty1/ty2 may be more fully zonked than evar@@ -1403,7 +1455,7 @@   = do { traceTcS "canDecomposableFunTy"                   (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2)        ; case ev of-           CtWanted { ctev_dest = dest }+           CtWanted (WantedCt { ctev_dest = dest })              -> do { (co, _, _) <- wrapUnifierTcS ev Nominal $ \ uenv ->                         do { let mult_env = uenv `updUEnvLoc` toInvisibleLoc                                                  `setUEnvRole` funRole role SelMult@@ -1413,8 +1465,8 @@                            ; return (mkNakedFunCo role af mult arg res) }                    ; setWantedEq dest co } -           CtGiven { ctev_evar = evar }-             | let pred_ty = mkPrimEqPredRole (eqRelRole eq_rel) ty1 ty2+           CtGiven (GivenCt { ctev_evar = evar })+             | let pred_ty = mkEqPred eq_rel ty1 ty2                    ev_co   = mkCoVarCo (setVarType evar pred_ty)                    -- setVarType: satisfy Note [mkSelCo precondition] in Coercion.hs                    -- Remember: ty1/ty2 may be more fully zonked than evar@@ -1431,20 +1483,18 @@  -- | Call canEqSoftFailure when canonicalizing an equality fails, but if the -- equality is representational, there is some hope for the future.-canEqSoftFailure :: CtEvidence -> EqRel -> TcType -> TcType+canEqSoftFailure :: CtIrredReason -> CtEvidence -> TcType -> TcType                  -> TcS (StopOrContinue (Either IrredCt a))-canEqSoftFailure ev NomEq ty1 ty2-  = canEqHardFailure ev ty1 ty2-canEqSoftFailure ev ReprEq ty1 ty2+canEqSoftFailure reason ev ty1 ty2   = do { (redn1, rewriters1) <- rewrite ev ty1        ; (redn2, rewriters2) <- rewrite ev ty2             -- We must rewrite the types before putting them in the             -- inert set, so that we are sure to kick them out when             -- new equalities become available-       ; traceTcS "canEqSoftFailure with ReprEq" $+       ; traceTcS "canEqSoftFailure" $          vcat [ ppr ev, ppr redn1, ppr redn2 ]        ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2-       ; finishCanWithIrred ReprEqReason new_ev }+       ; finishCanWithIrred reason new_ev }  -- | Call when canonicalizing an equality fails with utterly no hope. canEqHardFailure :: CtEvidence -> TcType -> TcType@@ -1626,7 +1676,7 @@                   -> TcKind             -- ki2                   -> TcS (StopOrContinue (Either IrredCt EqCt)) canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2--- See Note [Equalities with incompatible kinds]+-- See Note [Equalities with heterogeneous kinds] -- See Note [Kind Equality Orientation]  -- NB: preserve left-to-right orientation!! See wrinkle (W2) in@@ -1634,54 +1684,70 @@ --    NotSwapped: --        ev      :: (lhs1:ki1) ~r# (xi2:ki2) --        kind_co :: k11 ~# ki2               -- Same orientation as ev---        type_ev :: lhs1 ~r# (xi2 |> sym kind_co)+--        new_ev  :: lhs1 ~r# (xi2 |> sym kind_co) --    Swapped --        ev      :: (xi2:ki2) ~r# (lhs1:ki1) --        kind_co :: ki2 ~# ki1               -- Same orientation as ev---        type_ev :: (xi2 |> kind_co) ~r# lhs1--  = do { (kind_co, rewriters, unifs_happened) <- mk_kind_eq   -- :: ki1 ~N ki2-       ; if unifs_happened-              -- Unifications happened, so start again to do the zonking-              -- Otherwise we might put something in the inert set that isn't inert-         then startAgainWith (mkNonCanonical ev)-         else-    do { let lhs_redn = mkReflRedn role ps_xi1-             rhs_redn = mkGReflRightRedn role xi2 mb_sym_kind_co-             mb_sym_kind_co = case swapped of-                                NotSwapped -> mkSymCo kind_co-                                IsSwapped  -> kind_co--       ; traceTcS "Hetero equality gives rise to kind equality"-           (ppr swapped $$-            ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ])-       ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn--       ; let new_xi2 = mkCastTy ps_xi2 mb_sym_kind_co-       ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 }}+--        new_ev  :: (xi2 |> kind_co) ~r# lhs1+-- Note that we need the `sym` when we are /not/ swapped; hence `mk_sym_co` -  where-    mk_kind_eq :: TcS (CoercionN, RewriterSet, Bool)-    -- Returned kind_co has kind (k1 ~ k2) if NotSwapped, (k2 ~ k1) if Swapped-    -- Returned Bool = True if unifications happened, so we should retry-    mk_kind_eq = case ev of-      CtGiven { ctev_evar = evar }+  = case ev of+      CtGiven (GivenCt { ctev_evar = evar, ctev_loc = loc })         -> do { let kind_co  = mkKindCo (mkCoVarCo evar)-                    pred_ty  = unSwap swapped (mkNomPrimEqPred liftedTypeKind) ki1 ki2-                    kind_loc = mkKindEqLoc xi1 xi2 (ctev_loc ev)+                    pred_ty  = unSwap swapped mkNomEqPred ki1 ki2+                    kind_loc = mkKindEqLoc xi1 xi2 loc               ; kind_ev <- newGivenEvVar kind_loc (pred_ty, evCoercion kind_co)-              ; emitWorkNC [kind_ev]-              ; return (ctEvCoercion kind_ev, emptyRewriterSet, False) }+              ; emitWorkNC [CtGiven kind_ev]+              ; finish emptyRewriterSet (givenCtEvCoercion kind_ev) }        CtWanted {}-        -> do { (kind_co, cts, unifs) <- wrapUnifierTcS ev Nominal $ \uenv ->-                                         let uenv' = updUEnvLoc uenv (mkKindEqLoc xi1 xi2)-                                         in unSwap swapped (uType uenv') ki1 ki2-              ; return (kind_co, rewriterSetFromCts cts, not (null unifs)) }+         -> do { (kind_co, cts, unifs) <- wrapUnifierTcS ev Nominal $ \uenv ->+                                          let uenv' = updUEnvLoc uenv (mkKindEqLoc xi1 xi2)+                                          in unSwap swapped (uType uenv') ki1 ki2+                      -- mkKindEqLoc: any new constraints, arising from the kind+                      -- unification, say they thay come from unifying xi1~xi2+               ; if not (null unifs)+                 then -- Unifications happened, so start again to do the zonking+                      -- Otherwise we might put something in the inert set that isn't inert+                      startAgainWith (mkNonCanonical ev)+                 else +            assertPpr (not (isEmptyCts cts)) (ppr ev $$ ppr ki1 $$ ppr ki2) $+              -- assert: the constraints won't be empty because the two kinds differ,+              -- and there are no unifications, so we must have emitted one or+              -- more constraints+            finish (rewriterSetFromCts cts) kind_co }+                    -- rewriterSetFromCts: record in the /type/ unification xi1~xi2 that+                    -- it has been rewritten by any (unsolved) consraints in `cts`; that+                    -- stops xi1~xi2 from unifying until `cts` are solved. See (EIK2).+  where     xi1  = canEqLHSType lhs1     role = eqRelRole eq_rel +    finish rewriters kind_co+      = do { traceTcS "Hetero equality gives rise to kind equality"+                 (ppr swapped $$+                  ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ])+           ; new_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn+                -- rewriteEqEvidence adds any as-yet-unsolved equalities+                -- from the kind equality (namely `rewriters`) to the+                -- rewriter set for `new_ev`.  See (EIK2).++           -- Now `new_ev` is homogenous: carry on!+           ; canEqCanLHSHomo new_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 }++      where+        -- kind_co :: ki1 ~N ki2+        lhs_redn    = mkReflRedn role ps_xi1+        rhs_redn    = mkGReflRightRedn role xi2 sym_kind_co+        new_xi2     = mkCastTy ps_xi2 sym_kind_co++        -- Apply mkSymCo when /not/ swapped+        sym_kind_co = case swapped of+                         NotSwapped -> mkSymCo kind_co+                         IsSwapped  -> kind_co++ canEqCanLHSHomo :: CtEvidence          -- lhs ~ rhs                                        -- or, if swapped: rhs ~ lhs                 -> EqRel -> SwapFlag@@ -1884,84 +1950,106 @@ ----------------------- canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs   -- Try unification; for Wanted, Nominal equalities with a meta-tyvar on the LHS-  | isWanted ev      -- See Note [Do not unify Givens]-  , NomEq <- eq_rel  -- See Note [Do not unify representational equalities]-  , TyVarLHS tv <- lhs-  = do { given_eq_lvl <- getInnermostGivenEqLevel-       ; if not (touchabilityAndShapeTest given_eq_lvl tv rhs)-         then if | Just can_rhs <- canTyFamEqLHS_maybe rhs-                 -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs-                    -- See Note [Orienting TyVarLHS/TyFamLHS]--                 | otherwise-                 -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs-         else--    -- We have a touchable unification variable on the left-    do { check_result <- checkTouchableTyVarEq ev tv rhs-       ; case check_result of {-            PuFail reason+  | CtWanted wev <- ev         -- See Note [Do not unify Givens]+  , NomEq <- eq_rel            -- See Note [Do not unify representational equalities]+  , wantedCtHasNoRewriters wev -- See Note [Unify only if the rewriter set is empty]+  , TyVarLHS lhs_tv <- lhs+  = do  { given_eq_lvl <- getInnermostGivenEqLevel+        ; case simpleUnifyCheck UC_Solver given_eq_lvl lhs_tv rhs of+            SUC_CanUnify ->+              unify lhs_tv (mkReflRedn Nominal rhs)+            SUC_CannotUnify               | Just can_rhs <- canTyFamEqLHS_maybe rhs-              -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs-                -- Swap back: see Note [Orienting TyVarLHS/TyFamLHS]--              | reason `cterHasOnlyProblems` do_not_prevent_rewriting-              -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs-+              -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS]               | otherwise-              -> tryIrredInstead reason ev eq_rel swapped lhs rhs ;+              -> finish_no_unify+            SUC_NotSure ->+              -- We have a touchable unification variable on the left,+              -- and the top-shape check succeeded. These are both guaranteed+              -- by the fact that simpleUnifyCheck did not return SUC_CannotUnify.+              do  { let flags = unifyingLHSMetaTyVar_TEFTask ev lhs_tv+                  ; check_result <- wrapTcS (checkTyEqRhs flags rhs)+                  ; case check_result of+                      PuOK cts rhs_redn ->+                        do { emitWork cts+                           ; unify lhs_tv rhs_redn }+                      PuFail reason+                        | Just can_rhs <- canTyFamEqLHS_maybe rhs+                        -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS]+                        | reason `cterHasOnlyProblems` do_not_prevent_rewriting+                        ->+                          -- ContinueWith, to allow using this constraint for+                          -- rewriting (e.g. alpha[2] ~ beta[3]).+                          do { let role = eqRelRole eq_rel+                             ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped+                                 (mkReflRedn role (canEqLHSType lhs))+                                 (mkReflRedn role rhs)+                             ; continueWith $ Right $+                                 EqCt { eq_ev  = new_ev, eq_eq_rel = eq_rel+                                      , eq_lhs = lhs , eq_rhs = rhs }+                             }+                        | otherwise+                        -> try_irred reason+                  }+         }+  -- Otherwise unification is off the table+  | otherwise+  = finish_no_unify -            PuOK _ rhs_redn ->+  where+    -- We can't unify, but this equality can go in the inert set+    -- and be used to rewrite other constraints.+    finish_no_unify =+      canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs -    -- Success: we can solve by unification-    do { -- In the common case where rhs_redn is Refl, we don't need to rewrite-         -- the evidence, even if swapped=IsSwapped.   Suppose the original was-         --     [W] co : Int ~ alpha-         -- We unify alpha := Int, and set co := <Int>.  No need to-         -- swap to   co = sym co'-         --           co' = <Int>-         new_ev <- if isReflCo (reductionCoercion rhs_redn)-                   then return ev-                   else rewriteEqEvidence emptyRewriterSet ev swapped-                            (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn+    -- We can't unify, and this equality should not be used to rewrite+    -- other constraints (e.g. because it has an occurs check).+    -- So add it to the inert Irreds.+    try_irred reason =+      tryIrredInstead reason ev eq_rel swapped lhs rhs -       ; let tv_ty     = mkTyVarTy tv-             final_rhs = reductionReducedType rhs_redn+    -- We can't unify as-is, and want to flip the equality around.+    -- Example: alpha ~ F tys, flip it around to become the canonical+    -- equality f tys ~ alpha.+    swap_and_finish tv can_rhs =+      swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs -       ; traceTcS "Sneaky unification:" $-         vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs,-               text "Coercion:" <+> pprEq tv_ty final_rhs,-               text "Left Kind is:" <+> ppr (typeKind tv_ty),-               text "Right Kind is:" <+> ppr (typeKind final_rhs) ]+    -- We can unify; go ahead and do so.+    unify tv rhs_redn = -       -- Update the unification variable itself-       ; unifyTyVar tv final_rhs+      do { -- In the common case where rhs_redn is Refl, we don't need to rewrite+           -- the evidence, even if swapped=IsSwapped.   Suppose the original was+           --     [W] co : Int ~ alpha+           -- We unify alpha := Int, and set co := <Int>.  No need to+           -- swap to   co = sym co'+           --           co' = <Int>+           new_ev <- if isReflCo (reductionCoercion rhs_redn)+                     then return ev+                     else rewriteEqEvidence emptyRewriterSet ev swapped+                              (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn -       -- Provide Refl evidence for the constraint-       -- Ignore 'swapped' because it's Refl!-       ; setEvBindIfWanted new_ev EvCanonical $-         evCoercion (mkNomReflCo final_rhs)+         ; let tv_ty     = mkTyVarTy tv+               final_rhs = reductionReducedType rhs_redn -       -- Kick out any constraints that can now be rewritten-       ; kickOutAfterUnification [tv]+         ; traceTcS "Sneaky unification:" $+           vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs,+                 text "Coercion:" <+> pprEq tv_ty final_rhs,+                 text "Left Kind is:" <+> ppr (typeKind tv_ty),+                 text "Right Kind is:" <+> ppr (typeKind final_rhs) ] -       ; return (Stop new_ev (text "Solved by unification")) }}}}+         -- Update the unification variable itself+         ; unifyTyVar tv final_rhs -  -- Otherwise unification is off the table-  | otherwise-  = canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs+         -- Provide Refl evidence for the constraint+         -- Ignore 'swapped' because it's Refl!+         ; setEvBindIfWanted new_ev EvCanonical $+           evCoercion (mkNomReflCo final_rhs) -  where-    -- Some problems prevent /unification/ but not /rewriting/-    -- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3]-    --    we can't unify (skolem-escape); but it /is/ canonical,-    --    and hence we /can/ use it for rewriting-    -- Concrete-ness:  alpha[conc] ~ b[sk]-    --    We can use it to rewrite; we still have to solve the original-    do_not_prevent_rewriting :: CheckTyEqResult-    do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<>-                               cteProblem cteConcrete+         -- Kick out any constraints that can now be rewritten+         ; kickOutAfterUnification [tv] +         ; return (Stop new_ev (text "Solved by unification")) }+ --------------------------- -- Unification is off the table canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs@@ -1987,6 +2075,17 @@ --              -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs --              | otherwise +              | reason `cterHasOnlyProblems` do_not_prevent_rewriting+              -> do { let role = eqRelRole eq_rel+                    ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped+                        (mkReflRedn role (canEqLHSType lhs))+                        (mkReflRedn role rhs)+                    ; continueWith $ Right $+                        EqCt { eq_ev  = new_ev, eq_eq_rel = eq_rel+                             , eq_lhs = lhs , eq_rhs = rhs }+                    }++              | otherwise               -> tryIrredInstead reason ev eq_rel swapped lhs rhs              PuOK _ rhs_redn@@ -2003,6 +2102,18 @@                            , eq_lhs = lhs                            , eq_rhs = reductionReducedType rhs_redn } } } +-- | Some problems prevent /unification/ but not /rewriting/:+--+-- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3]+--    we can't unify (skolem-escape); but it /is/ canonical,+--    and hence we /can/ use it for rewriting+--+-- Concrete-ness:  alpha[conc] ~ b[sk]+--    We can use it to rewrite; we still have to solve the original+do_not_prevent_rewriting :: CheckTyEqResult+do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<>+                           cteProblem cteConcrete+ ---------------------- swapAndFinish :: CtEvidence -> EqRel -> SwapFlag               -> TcType -> CanEqLHS      -- ty ~ F tys@@ -2056,8 +2167,8 @@          evCoercion (mkReflCo (eqRelRole eq_rel) ty)        ; stopWith ev "Solved by reflexivity" } -{- Note [Equalities with incompatible kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Equalities with heterogeneous kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What do we do when we have an equality    (tv :: k1) ~ (rhs :: k2)@@ -2065,83 +2176,70 @@ where k1 and k2 differ? Easy: we create a coercion that relates k1 and k2 and use this to cast. To wit, from -  [X] (tv :: k1) ~ (rhs :: k2)+  [X] co1 :: (tv :: k1) ~ (rhs :: k2)  (where [X] is [G] or [W]), we go to -  [X] co :: k1 ~ k2-  [X] (tv :: k1) ~ ((rhs |> sym co) :: k1)+  co1 = co2 ; sym (GRefl kco)+  [X] co2 :: (tv :: k1) ~ ((rhs |> sym kco) :: k1)+  [X] kco :: k1 ~ k2  Wrinkles: -(EIK1) When X is W, the new type-level wanted is effectively rewritten by the-     kind-level one. We thus include the kind-level wanted in the RewriterSet-     for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.-     This is done in canEqCanLHSHetero.+(EIK1) When X=Wanted, the new type-level wanted for `co` is effectively rewritten by+     the kind-level one. We thus include the kind-level wanted in the RewriterSet+     for the type-level one. See Note [Wanteds rewrite Wanteds] in+     GHC.Tc.Types.Constraint.  This is done in canEqCanLHSHetero.  (EIK2) Suppose we have [W] (a::Type) ~ (b::Type->Type). The above rewrite will produce-        [W] w  : a ~ (b |> kw)-        [W] kw : Type ~ (Type->Type)--     But we do /not/ want to regard `w` as canonical, and use it for rewriting-     other constraints: `kw` is insoluble, and replacing something of kind-     `Type` with something of kind `Type->Type` (even wrapped in an insouluble-     cast) does not help, and doing so turns out to lead to much worse error-     messages.  (In particular, if 'a' is a unification variable, we might-     unify, losing the tracking info that it depends on solving `kw`.)--     Conclusion: if a RHS contains a coercion hole arising from fixing a hetero-kinded-     equality, treat the equality (`w` in this case) as non-canonical, so that-       * It will not be used for unification-       * It will not be used for rewriting-     Instead, it lands in the inert_irreds in the inert set, awaiting solution of-     that `kw`.+        [W] w (rewriters: {kw}) : a ~ (b |> kw)+        [W] kw                  : Type ~ (Type->Type) -     (EIK2a) We must later indeed unify if/when the kind-level wanted, `kw` gets-     solved. This is done in kickOutAfterFillingCoercionHole, which kicks out-     all equalities whose RHS mentions the filled-in coercion hole.  Note that-     it looks for type family equalities, too, because of the use of unifyTest-     in canEqTyVarFunEq.+     We track `w` as having `kw` in its rewriter set.  That will stop us unifying `w`+     (see Note [Unify only if the rewriter set is empty] in GHC.Tc.Solver.Equality). -     (EIK2b) What if the RHS mentions /other/ coercion holes?  How can that happen?  The-     main way is like this. Assume F :: forall k. k -> Type+    But `w` is still /canonical/, and used for rewriting other constraints.+    See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. That's important+    in general. Consider:         [W] kw : k  ~ Type         [W] w  : a ~ F k t      We can rewrite `w` with `kw` like this:-        [W] w' : a ~ F Type (t |> kw)+        [W] w' (rewriters: {kw}) : a ~ F Type (t |> kw)      The cast on the second argument of `F` is necessary to keep the appliation well-kinded.      There is nothing special here; no reason not treat w' as canonical, and use it for-     rewriting. Indeed tests JuanLopez only typechecks if we do.  So we'd like to treat-     this kind of equality as canonical.+     rewriting. Indeed test JuanLopez only typechecks if we do. -     Hence the ch_hetero_kind field in CoercionHole: it is True of constraints-     created by `canEqCanLHSHetero` to fix up hetero-kinded equalities; and False otherwise:+  So here is our implementation:+     * When doing the kind unification, any equality constraints we can't solve+       immediately get an origin that tells that the constraint arises from+       the kind of the parent type-equality.  See the calls to `mkKindEqLoc`+       in `canEqCanLHSHetero`. -     * An equality constraint is non-canonical if it mentions a hetero-kind-       CoercionHole on the RHS.  See the `hasCoercionHoleCo` test in GHC.Tc.Utils.checkCo.+     * We /also/ add these unsolved kind equalities to the `RewriterSet` of the+       parent constraint; see the call to `rewriteEqEvidence` in `finish` in+       `canEqCanLHSHetero`. -     * Hetero-kind CoercionHoles are created when the parent's CtOrigin is-       KindEqOrigin: see GHC.Tc.Utils.TcMType.newCoercionHole and friends.  We-       set this origin, via `mkKindLoc`, in `mk_kind_eq` in `canEqCanLHSHetero`.+     * When filling a coercion hole we kick out any equality constraints whose+       rewriter set mentions this hole.  See `kickOutAfterFillingCoercionHole` -(EIK3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the-     algorithm detailed here, producing [W] co :: k1 ~ k2, and adding-     [W] (a :: k1) ~ ((rhs |> sym co) :: k1) to the irreducibles. Some time-     later, we solve co, and fill in co's coercion hole. This kicks out-     the irreducible as described in (2).+(EIK3) Suppose we have [W] co1 : (a :: k1) ~ (rhs :: k2). We duly follow the+     algorithm detailed here, producing [W] kco :: k1 ~ k2, and adding+     [W] co2 : (a :: k1) ~ ((rhs |> sym kco) :: k1) to the inert set.+     Some time later, we solve `kco`, and fill in kco's coercion hole.+     This kicks out the inert equality `co2`       But now, during canonicalization, we see the cast and remove it, in-     canEqCast. By the time we get into canEqCanLHS, the equality is-     heterogeneous again, and the process repeats.+     `canEqCast`. By the time we get into `canEqCanLHS`, the equality is+     heterogeneous again, and the process repeats!       To avoid this, we don't strip casts off a type if the other type in the-     equality is a CanEqLHS (the scenario above can happen with a type-     family, too. testcase: typecheck/should_compile/T13822).+     equality is a CanEqLHS.  See the `CastTy` case of `can_eq_nc`.+     (The scenario above can happen with a type family, too.+      testcase: typecheck/should_compile/T13822).       And this is an improvement regardless: because tyvars can, generally,      unify with casted types, there's no reason to go through the work of-     stripping off the cast when the cast appears opposite a tyvar. This is-     implemented in the cast case of can_eq_nc.+     stripping off the cast when the cast appears opposite a tyvar.  Historical note: @@ -2278,7 +2376,7 @@  Note that * `cbv` is a fresh cycle breaker variable.-* `cbv` is a is a meta-tyvar, but it is completely untouchable.+* `cbv` is a meta-tyvar, but it is completely untouchable. * We track the cycle-breaker variables in inert_cycle_breakers in InertSet * We eventually fill in the cycle-breakers, with `cbv := F lhs`.   No one else fills in CycleBreakerTvs!@@ -2308,8 +2406,9 @@   [W] Arg alpha ~ cbv1   [W] Res alpha ~ cbv2 -where cbv1 and cbv2 are fresh TauTvs.  This is actually done by `break_wanted`-in `GHC.Tc.Solver.Monad.checkTouchableTyVarEq`.+where cbv1 and cbv2 are fresh TauTvs.  This is actually done within checkTyEqRhs,+called within canEqCanLHSFinish_try_unification, which will use the BreakWanted+FamAppBreaker.  Why TauTvs? See [Why TauTvs] below. @@ -2318,7 +2417,7 @@ unifying cbv1 and cbv2 immediately, achieving nothing.)  Next, we unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This unification happens immediately following a successful call to-checkTouchableTyVarEq, in canEqCanLHSFinish_try_unification.+checkTyEqRhs, in canEqCanLHSFinish_try_unification.  Now, we're here (including further context from our original example, from the top of the Note):@@ -2468,10 +2567,9 @@       However, we make no attempt to detect cases like a ~ (F a, F a) and use the      same tyvar to replace F a. The constraint solver will common them up later!-     (Cf. Note [Flattening type-family applications when matching instances] in-     GHC.Core.Unify, which goes to this extra effort.) However, this is really-     a very small corner case.  The investment to craft a clever, performant-     solution seems unworthwhile.+     (Cf. Note [Apartness and type families] in GHC.Core.Unify, which goes to+     this extra effort.) However, this is really a very small corner case.  The+     investment to craft a clever, performant solution seems unworthwhile.   (6) We often get the predicate associated with a constraint from its evidence      with ctPred. We thus must not only make sure the generated CEqCan's fields@@ -2559,16 +2657,15 @@   , isReflCo rhs_co   = return (setCtEvPredType old_ev new_pred) -  | CtGiven { ctev_evar = old_evar } <- old_ev+  | CtGiven (GivenCt { ctev_evar = old_evar }) <- old_ev   = do { let new_tm = evCoercion ( mkSymCo lhs_co                                   `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar)                                   `mkTransCo` rhs_co)-       ; newGivenEvVar loc (new_pred, new_tm) }+       ; CtGiven <$> newGivenEvVar loc (new_pred, new_tm) } -  | CtWanted { ctev_dest = dest-             , ctev_rewriters = rewriters } <- old_ev-  , let rewriters' = rewriters S.<> new_rewriters-  = do { (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRewriteRole old_ev) nlhs nrhs+  | CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters }) <- old_ev+  = do { let rewriters' = rewriters S.<> new_rewriters+       ; (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRewriteRole old_ev) nlhs nrhs        ; let co = maybeSymCo swapped $                   lhs_co `mkTransCo` hole_co `mkTransCo` mkSymCo rhs_co        ; setWantedEq dest co@@ -2577,7 +2674,7 @@                                             , ppr nrhs                                             , ppr co                                             , ppr new_rewriters ])-       ; return new_ev }+       ; return $ CtWanted new_ev }    where     new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs@@ -2599,17 +2696,17 @@ Then we can simply solve g2 from g1, thus g2 := g1.  Easy! But it's not so simple: -* If t is a type variable, the equalties might be oriented differently:+(CE1) If t is a type variable, the equalties might be oriented differently:       e.g. (g1 :: a~b) and (g2 :: b~a)   So we look both ways round.  Hence the SwapFlag result to   inertsCanDischarge. -* We can only do g2 := g1 if g1 can discharge g2; that depends on+(CE2) We can only do g2 := g1 if g1 can discharge g2; that depends on   (a) the role and (b) the flavour.  E.g. a representational equality   cannot discharge a nominal one; a Wanted cannot discharge a Given.   The predicate is eqCanRewriteFR. -* Visibility. Suppose  S :: forall k. k -> Type, and consider unifying+(CE3) Visibility. Suppose  S :: forall k. k -> Type, and consider unifying       S @Type (a::Type)  ~   S @(Type->Type) (b::Type->Type)   From the first argument we get (Type ~ Type->Type); from the second   argument we get (a ~ b) which in turn gives (Type ~ Type->Type).@@ -2624,13 +2721,31 @@   So when combining two otherwise-identical equalites, we want to   keep the visible one, and discharge the invisible one.  Hence the   call to strictly_more_visible.++(CE4) Suppose we have this set up (#25440):+   Inert:     [W] g1: F a ~ a Int    (arising from (F a ~ a Int)+   Work item: [W] g2: F alpha ~ F a  (arising from (F alpha ~ F a)+   We rewrite g2 with g1, to give+              [W] g2{rw:g1} : F alpha ~ a Int+   Now if F is injective we can get [W] alpha~a, and hence alpha:=a, and+   we kick out g1. Now we have two constraints+       [W] g1        : F a ~ a Int  (arising from (F a ~ a Int)+       [W] g2{rw:g1} : F a ~ a Int  (arising from (F alpha ~ F a)+   If we end up with g2 in the inert set (not g1) we'll get a very confusing+   error message that we can solve (F a ~ a Int)+       arising from F a ~ F a++   TL;DR: Better to hang on to `g1` (with no rewriters), in preference+   to `g2` (which has a rewriter).++   See (WRW1) in Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. -}  tryInertEqs :: EqCt -> SolverStage () tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel })   = Stage $     do { inerts <- getInertCans-       ; if | Just (ev_i, swapped) <- inertsCanDischarge inerts work_item+       ; if | Just (ev_i, swapped) <- inertsEqsCanDischarge inerts work_item             -> do { setEvBindIfWanted ev EvCanonical $                     evCoercion (maybeSymCo swapped $                                 downgradeRole (eqRelRole eq_rel)@@ -2641,10 +2756,10 @@             | otherwise             -> continueWith () } -inertsCanDischarge :: InertCans -> EqCt-                   -> Maybe ( CtEvidence  -- The evidence for the inert-                            , SwapFlag )  -- Whether we need mkSymCo-inertsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w+inertsEqsCanDischarge :: InertCans -> EqCt+                      -> Maybe ( CtEvidence  -- The evidence for the inert+                               , SwapFlag )  -- Whether we need mkSymCo+inertsEqsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w                                 , eq_ev = ev_w, eq_eq_rel = eq_rel })   | (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i                                 , eq_eq_rel = eq_rel }@@ -2669,25 +2784,31 @@     loc_w  = ctEvLoc ev_w     flav_w = ctEvFlavour ev_w     fr_w   = (flav_w, eq_rel)+    empty_rw_w = isEmptyRewriterSet (ctEvRewriters ev_w)      inert_beats_wanted ev_i eq_rel       = -- eqCanRewriteFR:        see second bullet of Note [Combining equalities]-        -- strictly_more_visible: see last bullet of Note [Combining equalities]         fr_i `eqCanRewriteFR` fr_w-        && not ((loc_w `strictly_more_visible` ctEvLoc ev_i)-                 && (fr_w `eqCanRewriteFR` fr_i))+        && not (prefer_wanted ev_i && (fr_w `eqCanRewriteFR` fr_i))       where         fr_i = (ctEvFlavour ev_i, eq_rel) -    -- See Note [Combining equalities], final bullet+    -- See (CE3) in Note [Combining equalities]     strictly_more_visible loc1 loc2        = not (isVisibleOrigin (ctLocOrigin loc2)) &&          isVisibleOrigin (ctLocOrigin loc1) -inertsCanDischarge _ _ = Nothing+    prefer_wanted ev_i+      =  (loc_w `strictly_more_visible` ctEvLoc ev_i)+             -- strictly_more_visible: see (CE3) in Note [Combining equalities]+      || (empty_rw_w && not (isEmptyRewriterSet (ctEvRewriters ev_i)))+             -- Prefer the one that has no rewriters+             -- See (CE4) in Note [Combining equalities] +inertsEqsCanDischarge _ _ = Nothing  + {- Note [Do not unify Givens] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this GADT match@@ -2730,6 +2851,34 @@ See also #15144, which was caused by unifying a representational equality. +Note that it does however make sense to perform such unifications, as a last+resort, when doing top-level defaulting.+See Note [Defaulting representational equalities].++Note [Unify only if the rewriter set is empty]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    co (rewriters = {co1,co2}) :: alpha ~# blah+If we unify before solving `co1` and `co2` (which might well be insoluble)+we destroy the careful tracking of Note [Wanteds rewrite Wanteds] in+GHC.Tc.Types.Constraint.  So we decline to unify any equality with a+non-empty rewriter set: see (REWRITERS) in Note [Unification preconditions]+in GHC.Tc.Utils.++Wrinkles:++(URW1) We may, however, be willing to /default/ such an equality; see+   (DE6) in Note [Defaulting equalities] in GHC.Tc.Solver.Default.++(URW2) If we have `co` in the inert set, and we solve `co1` and `co2`,+   we should kick out `co` so that we can now unify it, which might+   unlock other stuff.  See `kickOutAfterFillingCoercionHole` in+   GHC.Tc.Solver.Monad.++   However the solver prioritises equalities with an empty rewriter+   set, to try to avoid unnecessary kick-out.  See GHC.Tc.Types.Constraint+   Note [Prioritise Wanteds with empty RewriterSet] esp (PER1)+ Note [Solve by unification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we solve@@ -2808,7 +2957,7 @@     do { ev_binds_var <- getTcEvBindsVar        ; ics <- getInertCans        ; if isWanted ev                       -- Never look up Givens in quantified constraints-         && not (null (inert_insts ics))      -- Shortcut common case+         && not (null (inert_qcis ics))       -- Shortcut common case          && not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications]          then try_for_qci          else continueWith () }@@ -2913,7 +3062,7 @@  When this was originally conceived, it was necessary to avoid a loop in T13135. That loop is now avoided by continuing with the kind equality (not the type-equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds]).+equality) in canEqCanLHSHetero (see Note [Equalities with heterogeneous kinds]). However, the idea of working left-to-right still seems worthwhile, and so the calls to 'reverse' remain. @@ -2976,7 +3125,7 @@ -------------------- improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool -- TyCon is definitely a type family--- See Note [FunDep and implicit parameter reactions]+-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs_ty })   | isGiven ev = improveGivenTopFunEqs  fam_tc args ev rhs_ty   | otherwise  = improveWantedTopFunEqs fam_tc args ev rhs_ty@@ -3036,6 +3185,7 @@  improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn] -- Interact with top-level instance declarations+-- See Section 5.2 in the Injective Type Families paper improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty   = concatMapM do_one branches   where@@ -3053,7 +3203,8 @@     do_one :: CoAxBranch -> TcS [TypeEqn]     do_one branch@(CoAxBranch { cab_tvs = branch_tvs, cab_lhs = branch_lhs_tys, cab_rhs = branch_rhs })       | let in_scope1 = in_scope `extendInScopeSetList` branch_tvs-      , Just subst <- tcUnifyTyWithTFs False in_scope1 branch_rhs rhs_ty+      , Just subst <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty+                      -- False: matching, not unifying       = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst                  unsubstTvs = filterOut inSubst branch_tvs                  -- The order of unsubstTvs is important; it must be@@ -3065,13 +3216,20 @@                 -- be sure to apply the current substitution to a's kind.                 -- Hence instFlexiX.   #13135 was an example. +           ; traceTcS "improve_inj_top" $+             vcat [ text "branch_rhs" <+> ppr branch_rhs+                  , text "rhs_ty" <+> ppr rhs_ty+                  , text "subst" <+> ppr subst+                  , text "subst1" <+> ppr subst1 ]            ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch-             then return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys)+             then do { traceTcS "improv_inj_top1" (ppr branch_lhs_tys)+                     ; return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) }                   -- NB: The fresh unification variables (from unsubstTvs) are on the left                   --     See Note [Improvement orientation]-             else return [] }+             else do { traceTcS "improve_inj_top2" empty; return []  } }       | otherwise-      = return []+      = do { traceTcS "improve_inj_top:fail" (ppr branch_rhs $$ ppr rhs_ty $$ ppr in_scope $$ ppr branch_tvs)+           ; return [] }      in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty) @@ -3162,7 +3320,7 @@ -- the current work item with inert CFunEqs (boh Given and Wanted) -- E.g.   x + y ~ z,   x + y' ~ z   =>   [W] y ~ y' ----- See Note [FunDep and implicit parameter reactions]+-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs   | null improvement_eqns   = return False
compiler/GHC/Tc/Solver/Irred.hs view
@@ -39,10 +39,6 @@        ; simpleStage (updInertIrreds irred)        ; stopWithStage (irredCtEvidence irred) "Kept inert IrredCt" } -updInertIrreds :: IrredCt -> TcS ()-updInertIrreds irred-  = do { tc_lvl <- getTcLevel-       ; updInertCans $ addIrredToCans tc_lvl irred }  {- ********************************************************************* *                                                                      *
compiler/GHC/Tc/Solver/Monad.hs view
@@ -1,2386 +1,2420 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-orphans #-}---- | Monadic definitions for the constraint solver-module GHC.Tc.Solver.Monad (--    -- The TcS monad-    TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,-    failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS,-    runTcSEqualities,-    nestTcS, nestImplicTcS, setEvBindsTcS,-    emitImplicationTcS, emitTvImplicationTcS,-    emitFunDepWanteds,--    selectNextWorkItem,-    getWorkList,-    updWorkListTcS,-    pushLevelNoWorkList,--    runTcPluginTcS, recordUsedGREs,-    matchGlobalInst, TcM.ClsInstResult(..),--    QCInst(..),--    -- The pipeline-    StopOrContinue(..), continueWith, stopWith,-    startAgainWith, SolverStage(Stage, runSolverStage), simpleStage,-    stopWithStage, nopStage,--    -- Tracing etc-    panicTcS, traceTcS, tryEarlyAbortTcS,-    traceFireTcS, bumpStepCountTcS, csTraceTcS,-    wrapErrTcS, wrapWarnTcS,-    resetUnificationFlag, setUnificationFlag,--    -- Evidence creation and transformation-    MaybeNew(..), freshGoals, isFresh, getEvExpr,-    CanonicalEvidence(..),--    newTcEvBinds, newNoTcEvBinds,-    newWantedEq, emitNewWantedEq,-    newWanted,-    newWantedNC, newWantedEvVarNC,-    newBoundEvVarId,-    unifyTyVar, reportUnifications,-    setEvBind, setWantedEq,-    setWantedEvTerm, setEvBindIfWanted,-    newEvVar, newGivenEvVar, emitNewGivens,-    checkReductionDepth,-    getSolvedDicts, setSolvedDicts,--    getInstEnvs, getFamInstEnvs,                -- Getting the environments-    getTopEnv, getGblEnv, getLclEnv, setSrcSpan,-    getTcEvBindsVar, getTcLevel,-    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,-    tcLookupClass, tcLookupId, tcLookupTyCon,---    -- Inerts-    updInertSet, updInertCans,-    getHasGivenEqs, setInertCans,-    getInertEqs, getInertCans, getInertGivens,-    getInertInsols, getInnermostGivenEqLevel,-    getInertSet, setInertSet,-    getUnsolvedInerts,-    removeInertCts, getPendingGivenScs,-    insertFunEq, addInertForAll,-    emitWorkNC, emitWork,-    lookupInertDict,--    -- The Model-    kickOutAfterUnification, kickOutRewritable,--    -- Inert Safe Haskell safe-overlap failures-    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,-    getSafeOverlapFailures,--    -- Inert solved dictionaries-    updSolvedDicts, lookupSolvedDict,--    -- Irreds-    foldIrreds,--    -- The family application cache-    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,-    pprKicked,--    -- Instantiation-    instDFunType,--    -- Unification-    wrapUnifierTcS, unifyFunDeps, uPairsTcM, unifyForAllBody,--    -- MetaTyVars-    newFlexiTcSTy, instFlexiX,-    cloneMetaTyVar,-    tcInstSkolTyVarsX,--    TcLevel,-    isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,-    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,-    zonkTyCoVarsAndFVList,-    zonkSimples, zonkWC,-    zonkTyCoVarKind,--    -- References-    newTcRef, readTcRef, writeTcRef, updTcRef,--    -- Misc-    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,-    matchFam, matchFamTcM,-    checkWellStagedDFun,-    pprEq,--    -- Enforcing invariants for type equalities-    checkTypeEq, checkTouchableTyVarEq-) 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, tcLookupTyCon-       , topIdLvl )-import GHC.Tc.Zonk.Monad ( ZonkM )-import qualified GHC.Tc.Zonk.TcType  as TcM-import qualified GHC.Tc.Zonk.Type as TcM--import GHC.Driver.DynFlags--import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon )-import GHC.Tc.Instance.FunDeps( FunDepEqn(..) )---import GHC.Tc.Solver.Types-import GHC.Tc.Solver.InertSet-import GHC.Tc.Errors.Types--import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Unify--import GHC.Tc.Types.Evidence-import GHC.Tc.Types-import GHC.Tc.Types.Origin-import GHC.Tc.Types.CtLoc-import GHC.Tc.Types.Constraint--import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName )--import GHC.Core.Type-import GHC.Core.TyCo.Rep as Rep-import GHC.Core.Coercion-import GHC.Core.Coercion.Axiom( TypeEqn )-import GHC.Core.Predicate-import GHC.Core.Reduction-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Core.Unify (typesAreApart)--import GHC.Types.Name-import GHC.Types.TyThing-import GHC.Types.Name.Reader-import GHC.Types.DefaultEnv ( DefaultEnv )-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Types.Unique.Supply-import GHC.Types.Unique.Set( elementOfUniqSet )--import GHC.Unit.Module ( HasModule, getModule, extractModule, moduleUnit, primUnit, ghcInternalUnit, bignumUnit)-import qualified GHC.Rename.Env as TcM--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Logger-import GHC.Utils.Misc (HasDebugCallStack, (<||>))--import GHC.Data.Bag as Bag-import GHC.Data.Pair--import GHC.Utils.Monad--import GHC.Exts (oneShot)-import Control.Monad-import Data.IORef-import Data.List ( mapAccumL )-import Data.Foldable-import qualified Data.Semigroup as S-import GHC.Types.SrcLoc-import GHC.Rename.Env--#if defined(DEBUG)-import GHC.Types.Unique.Set (nonDetEltsUniqSet)-import GHC.Data.Graph.Directed-#endif--{- *********************************************************************-*                                                                      *-               SolverStage and StopOrContinue-*                                                                      *-********************************************************************* -}--{- Note [The SolverStage monad]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The SolverStage monad allows us to write simple code like that in-GHC.Tc.Solver.solveEquality.   At the time of writing it looked like-this (may get out of date but the idea is clear):--solveEquality :: ... -> SolverStage Void-solveEquality ev eq_rel ty1 ty2-  = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2-       ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2'-       ; case mb_canon of {-            Left irred_ct -> do { tryQCsIrredEqCt irred_ct-                                ; solveIrred irred_ct } ;-            Right eq_ct   -> do { tryInertEqs eq_ct-                                ; tryFunDeps  eq_ct-                                ; tryQCsEqCt  eq_ct-                                ; simpleStage (updInertEqs eq_ct)-                                ; stopWithStage (eqCtEvidence eq_ct) ".." }}}--Each sub-stage can elect to-  (a) ContinueWith: continue to the next stasge-  (b) StartAgain:   start again at the beginning of the pipeline-  (c) Stop:         stop altogether; constraint is solved--These three possiblities are described by the `StopOrContinue` data type.-The `SolverStage` monad does the plumbing.--Notes:--(SM1) Each individual stage pretty quickly drops down into-         TcS (StopOrContinue a)-    because the monadic plumbing of `SolverStage` is relatively ineffienct,-    with that three-way split.--(SM2) We use `SolverStage Void` to express the idea that ContinueWith is-    impossible; we don't need to pattern match on it as a possible outcome:A-    see GHC.Tc.Solver.Solve.solveOne.   To that end, ContinueWith is strict.--}--data StopOrContinue a-  = StartAgain Ct     -- Constraint is not solved, but some unifications-                      --   happened, so go back to the beginning of the pipeline--  | ContinueWith !a   -- The constraint was not solved, although it may have-                      --   been rewritten.  It is strict so that-                      --   ContinueWith Void can't happen; see (SM2) in-                      --   Note [The SolverStage monad]--  | Stop CtEvidence   -- The (rewritten) constraint was solved-         SDoc         -- Tells how it was solved-                      -- Any new sub-goals have been put on the work list-  deriving (Functor)--instance Outputable a => Outputable (StopOrContinue a) where-  ppr (Stop ev s)      = text "Stop" <> parens (s $$ text "ev:" <+> ppr ev)-  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w-  ppr (StartAgain w)   = text "StartAgain" <+> ppr w--newtype SolverStage a = Stage { runSolverStage :: TcS (StopOrContinue a) }-  deriving( Functor )--instance Applicative SolverStage where-  pure x = Stage (return (ContinueWith x))-  (<*>)  = ap--instance Monad SolverStage where-  return          = pure-  (Stage m) >>= k = Stage $-                    do { soc <- m-                       ; case soc of-                           StartAgain x   -> return (StartAgain x)-                           Stop ev d      -> return (Stop ev d)-                           ContinueWith x -> runSolverStage (k x) }--nopStage :: a -> SolverStage a-nopStage res = Stage (continueWith res)--simpleStage :: TcS a -> SolverStage a--- Always does a ContinueWith; no Stop or StartAgain-simpleStage thing = Stage (do { res <- thing; continueWith res })--startAgainWith :: Ct -> TcS (StopOrContinue a)-startAgainWith ct = return (StartAgain ct)--continueWith :: a -> TcS (StopOrContinue a)-continueWith ct = return (ContinueWith ct)--stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)-stopWith ev s = return (Stop ev (text s))--stopWithStage :: CtEvidence -> String -> SolverStage a-stopWithStage ev s = Stage (stopWith ev s)---{- *********************************************************************-*                                                                      *-                   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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As an optimisation, we avoid adding duplicate quantified instances to the-inert set; we use a simple duplicate check using tcEqType for simplicity,-even though it doesn't account for superficial differences, e.g. it will count-the following two constraints as different (#22223):--  - forall a b. C a b-  - forall b a. C a b--The main logic that allows us to pick local instances, even in the presence of-duplicates, is explained in Note [Use only the best matching quantified constraint]-in GHC.Tc.Solver.Dict.--}--{- *********************************************************************-*                                                                      *-                  Kicking out-*                                                                      *-************************************************************************--}---------------------------------------------kickOutRewritable  :: KickOutSpec -> CtFlavourRole -> TcS ()-kickOutRewritable ko_spec new_fr-  = do { ics <- getInertCans-       ; let (kicked_out, ics') = kickOutRewritableLHS ko_spec new_fr ics-             n_kicked = lengthBag kicked_out-       ; setInertCans ics'--       ; unless (isEmptyBag kicked_out) $-         do { emitWork 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 = foldr add_one emptyVarSet kicked_out-                  add_one :: Ct -> VarSet -> VarSet-                  add_one ct vs | CtGiven { ctev_evar = ev_var } <- ctEvidence ct-                                = vs `extendVarSet` ev_var-                                | otherwise = vs--            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&-                   -- if this isn't true, no use looking through the constraints-                    not (isEmptyVarSet kicked_given_ev_vars)) $-              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"-                            (ppr kicked_given_ev_vars)-                 ; dropFromFamAppCache kicked_given_ev_vars }--            ; csTraceTcS $-              hang (text "Kick out")-                 2 (vcat [ text "n-kicked =" <+> int n_kicked-                         , text "kicked_out =" <+> ppr kicked_out-                         , text "Residual inerts =" <+> ppr ics' ]) } }--kickOutAfterUnification :: [TcTyVar] -> TcS ()-kickOutAfterUnification tvs-  | null tvs-  = return ()-  | otherwise-  = do { let tv_set = mkVarSet tvs--       ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq)-                     -- Given because the tv := xi is given; NomEq because-                     -- only nominal equalities are solved by unification--       -- Set the unification flag if we have done outer unifications-       -- that might affect an earlier implication constraint-       ; let min_tv_lvl = foldr1 minTcLevel (map tcTyVarLevel tvs)-       ; ambient_lvl <- getTcLevel-       ; when (ambient_lvl `strictlyDeeperThan` min_tv_lvl) $-         setUnificationFlag min_tv_lvl--       ; traceTcS "kickOutAfterUnification" (ppr tvs $$ text "n_kicked =" <+> ppr n_kicked)-       ; return n_kicked }--kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()--- See Wrinkle (EIK2a) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality--- It's possible that this could just go ahead and unify, but could there be occurs-check--- problems? Seems simpler just to kick out.-kickOutAfterFillingCoercionHole hole-  = do { ics <- getInertCans-       ; let (kicked_out, ics') = kick_out ics-             n_kicked           = lengthBag kicked_out--       ; unless (n_kicked == 0) $-         do { updWorkListTcS (extendWorkListCts (fmap CIrredCan 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-    kick_out :: InertCans -> (Bag IrredCt, InertCans)-    kick_out ics@(IC { inert_irreds = irreds })-      = -- We only care about irreds here, because any constraint blocked-        -- by a coercion hole is an irred.  See wrinkle (EIK2a) in-        -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-        (irreds_to_kick, ics { inert_irreds = irreds_to_keep })-      where-        (irreds_to_kick, irreds_to_keep) = partitionBag kick_ct irreds--    kick_ct :: IrredCt -> Bool-         -- True: kick out; False: keep.-    kick_ct ct-      | IrredCt { ir_ev = ev, ir_reason = reason } <- ct-      , CtWanted { ctev_rewriters = RewriterSet rewriters } <- ev-      , NonCanonicalReason ctyeq <- reason-      , ctyeq `cterHasProblem` cteCoercionHole-      , hole `elementOfUniqSet` rewriters-      = True-      | otherwise-      = False-----------------addInertSafehask :: InertCans -> DictCt -> InertCans-addInertSafehask ics item-  = ics { inert_safehask = addDict item (inert_dicts ics) }--insertSafeOverlapFailureTcS :: InstanceWhat -> DictCt -> 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 (Bag DictCt)--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver-getSafeOverlapFailures- = do { IC { inert_safehask = safehask } <- getInertCans-      ; return $ foldDicts consBag safehask emptyBag }-----------------updSolvedDicts :: InstanceWhat -> DictCt -> TcS ()--- Conditionally add a new item in the solved set of the monad--- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet-updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })-  | isWanted ev-  , instanceReturnsDictCon what-  = do { is_callstack    <- is_tyConTy isCallStackTy        callStackTyConName-       ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName-       ; let contains_callstack_or_exceptionCtx =-               mentionsIP-                 (const True)-                    -- NB: the name of the call-stack IP is irrelevant-                    -- e.g (?foo :: CallStack) counts!-                 (is_callstack <||> is_exceptionCtx)-                 cls tys-       -- See Note [Don't add HasCallStack constraints to the solved set]-       ; unless contains_callstack_or_exceptionCtx $-    do { traceTcS "updSolvedDicts:" $ ppr dict_ct-       ; updInertSet $ \ ics ->-           ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) }-       } }-  | otherwise-  = return ()-  where--    -- Return a predicate that decides whether a type is CallStack-    -- or ExceptionContext, accounting for e.g. type family reduction, as-    -- per Note [Using typesAreApart when calling mentionsIP].-    ---    -- See Note [Using isCallStackTy in mentionsIP].-    is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)-    is_tyConTy is_eq tc_name-      = do {  mb_tc <- wrapTcS $ do-                mod <- tcg_mod <$> TcM.getGblEnv-                if moduleUnit mod `elem` [primUnit, ghcInternalUnit, bignumUnit]-                then return Nothing-                else Just <$> TcM.tcLookupTyCon tc_name-           ; case mb_tc of-              Just tc ->-                return $ \ ty -> not (typesAreApart ty (mkTyConTy tc))-              Nothing ->-                return is_eq-           }--{- Note [Don't add HasCallStack constraints to the solved set]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must not add solved Wanted dictionaries that mention HasCallStack constraints-to the solved set, or we might fail to accumulate the proper call stack, as was-reported in #25529.--Recall that HasCallStack constraints (and the related HasExceptionContext-constraints) are implicit parameter constraints, and are accumulated as per-Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence.--When we solve a Wanted that contains a HasCallStack constraint, we don't want-to cache the result, because re-using that solution means re-using the call-stack-in a different context!--See also Note [Shadowing of implicit parameters], which deals with a similar-problem with Given implicit parameter constraints.--Note [Using isCallStackTy in mentionsIP]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To implement Note [Don't add HasCallStack constraints to the solved set],-we need to check whether a constraint contains a HasCallStack or HasExceptionContext-constraint. We do this using the 'mentionsIP' function, but as per-Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:--  mentionsIP-    (const True) -- (ignore the implicit parameter string)-    (isCallStackTy <||> isExceptionContextTy)--because this does not account for e.g. a type family that reduces to CallStack.-The predicate we want to use instead is:--    \ ty -> not (typesAreApart ty callStackTy && typesAreApart ty exceptionContextTy)--However, this is made difficult by the fact that CallStack and ExceptionContext-are not wired-in types; they are only known-key. This means we must look them-up using 'tcLookupTyCon'. However, this might fail, e.g. if we are in the middle-of typechecking ghc-internal and these data-types have not been typechecked yet!--In that case, we simply fall back to the naive 'isCallStackTy'/'isExceptionContextTy'-logic.--Note that it would be somewhat painful to wire-in ExceptionContext: at the time-of writing (March 2025), this would require wiring in the ExceptionAnnotation-class, as well as SomeExceptionAnnotation, which is a data type with existentials.--}--getSolvedDicts :: TcS (DictMap DictCt)-getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) }--setSolvedDicts :: DictMap DictCt -> TcS ()-setSolvedDicts solved_dicts-  = updInertSet $ \ ics ->-    ics { inert_solved_dicts = solved_dicts }--{- *********************************************************************-*                                                                      *-                  Other inert-set operations-*                                                                      *-********************************************************************* -}--updInertSet :: (InertSet -> InertSet) -> TcS ()--- Modify the inert set with the supplied function-updInertSet upd_fn-  = do { is_var <- getInertSetRef-       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var-                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }--getInertCans :: TcS InertCans-getInertCans = do { inerts <- getInertSet; return (inert_cans inerts) }--setInertCans :: InertCans -> TcS ()-setInertCans ics = updInertSet $ \ 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 <- getInertSetRef-       ; 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-  = updInertSet $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }--updInertSafehask :: (DictMap DictCt -> DictMap DictCt) -> TcS ()--- Modify the inert set with the supplied function-updInertSafehask upd_fn-  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }--getInertEqs :: TcS InertEqs-getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }--getInnermostGivenEqLevel :: TcS TcLevel-getInnermostGivenEqLevel = do { inert <- getInertCans-                              ; return (inert_given_eq_lvl inert) }---- | Retrieves all insoluble constraints from the inert set,--- specifically including Given constraints.------ This consists of:------  - insoluble equalities, such as @Int ~# Bool@;---  - constraints that are top-level custom type errors, of the form---    @TypeError msg@, but not constraints such as @Eq (TypeError msg)@---    in which the type error is nested;---  - unsatisfiable constraints, of the form @Unsatisfiable msg@.------ The inclusion of Givens is important for pattern match warnings, as we--- want to consider a pattern match that introduces insoluble Givens to be--- redundant (see Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver).-getInertInsols :: TcS Cts-getInertInsols-  = do { inert <- getInertCans-       ; let insols = filterBag insolubleIrredCt (inert_irreds inert)-             unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey-       ; return $ fmap CDictCan unsats `unionBags` fmap CIrredCan insols }--getInertGivens :: TcS [Ct]--- Returns the Given constraints in the inert set-getInertGivens-  = do { inerts <- getInertCans-       ; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts)-                     $ foldDicts  ((:) . CDictCan) (inert_dicts inerts)-                     $ foldFunEqs ((:) . CEqCan)    (inert_funeqs inerts)-                     $ foldTyEqs  ((:) . CEqCan)    (inert_eqs inerts)-                     $ []-       ; return (filter isGivenCt all_cts) }--getPendingGivenScs :: TcS [Ct]--- Find all inert Given dictionaries, or quantified constraints, such that---     1. cc_pend_sc flag has fuel strictly > 0---     2. belongs to the current level--- For each such dictionary:--- * Return it (with unmodified cc_pend_sc) in sc_pending--- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand---   to record that we have expanded superclasses for this dict-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 ++ map CDictCan sc_pend_dicts--    sc_pend_dicts :: [DictCt]-    sc_pend_dicts = foldDicts get_pending dicts []-    dicts' = foldr exhaustAndAdd dicts sc_pend_dicts--    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts--    exhaustAndAdd :: DictCt -> DictMap DictCt -> DictMap DictCt-    exhaustAndAdd ct dicts = addDict (ct {di_pend_sc = doNotExpand}) dicts-    -- Exhaust the fuel for this constraint before adding it as-    -- we don't want to expand these constraints again--    get_pending :: DictCt -> [DictCt] -> [DictCt]  -- Get dicts with cc_pend_sc > 0-    get_pending dict dicts-        | isPendingScDictCt dict-        , belongs_to_this_level (dictCtEvidence dict)-        = dict : dicts-        | otherwise-        = dicts--    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)-    get_pending_inst cts qci@(QCI { qci_ev = ev })-       | Just qci' <- pendingScInst_maybe qci-       , belongs_to_this_level ev-       = (CQuantCan qci : cts, qci')-       -- qci' have their fuel exhausted-       -- we don't want to expand these constraints again-       -- qci is expanded-       | otherwise-       = (cts, qci)--    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) `sameDepthAs` this_lvl-    -- We only want Givens from this level; see (3a) in-    -- Note [The superclass story] in GHC.Tc.Solver.Dict--getUnsolvedInerts :: TcS ( Bag Implication-                         , Cts )   -- All simple constraints--- Return all the unsolved [Wanted] 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 CEqCan)    tv_eqs emptyCts-            unsolved_fun_eqs = foldFunEqs (add_if_unsolved CEqCan)    fun_eqs emptyCts-            unsolved_irreds  = foldr      (add_if_unsolved CIrredCan) emptyCts irreds-            unsolved_dicts   = foldDicts  (add_if_unsolved CDictCan)  idicts emptyCts--      ; implics <- getWorkListImplics--      ; traceTcS "getUnsolvedInerts" $-        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs-             , text "fun eqs =" <+> ppr unsolved_fun_eqs-             , text "dicts =" <+> ppr unsolved_dicts-             , text "irreds =" <+> ppr unsolved_irreds-             , text "implics =" <+> ppr implics ]--      ; return ( implics, unsolved_tv_eqs `unionBags`-                          unsolved_fun_eqs `unionBags`-                          unsolved_irreds `unionBags`-                          unsolved_dicts ) }-  where-    add_if_unsolved :: (a -> Ct) -> a -> Cts -> Cts-    add_if_unsolved mk_ct thing cts-      | isWantedCt ct = ct `consCts` cts-      | otherwise     = cts-      where-        ct = mk_ct thing--getHasGivenEqs :: TcLevel             -- TcLevel of this implication-               -> TcS ( HasGivenEqs   -- are there Given equalities?-                      , InertIrreds ) -- 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 given_insols = filterBag insoluble_given_equality irreds-                      -- Specifically includes ones that originated in some-                      -- outer context but were refined to an insoluble by-                      -- a local equality; so no level-check needed--             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and-             -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet-             has_ge | ge_lvl `sameDepthAs` 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 given_insols]-       ; return (has_ge, given_insols) }-  where-    insoluble_given_equality :: IrredCt -> Bool-    -- Check for unreachability; specifically do not include UserError/Unsatisfiable-    insoluble_given_equality (IrredCt { ir_ev = ev, ir_reason = reason })-       = isInsolubleReason reason && isGiven ev--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 dict_ct -> is { inert_dicts = delDict dict_ct (inert_dicts is) }-      CEqCan    eq_ct  -> delEq    eq_ct is-      CIrredCan ir_ct  -> delIrred ir_ct is-      CQuantCan {}     -> panic "removeInertCt: CQuantCan"-      CNonCanonical {} -> panic "removeInertCt: CNonCanonical"---- | Looks up a family application in the inerts.-lookupFamAppInert :: (CtFlavourRole -> Bool)  -- can it rewrite the target?-                  -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole))-lookupFamAppInert rewrite_pred fam_tc tys-  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getInertSet-       ; return (lookup_inerts inert_funeqs) }-  where-    lookup_inerts inert_funeqs-      | Just ecl <- findFunEq inert_funeqs fam_tc tys-      , Just (EqCt { eq_ev = ctev, eq_rhs = rhs })-          <- find (rewrite_pred . eqCtFlavourRole) ecl-      = Just (mkReduction (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 <- getInertSet-       ; let mb_solved = lookupSolvedDict inerts loc cls tys-             mb_inert  = fmap dictCtEvidence (lookupInertDict (inert_cans inerts) loc cls tys)-       ; return $ do -- Maybe monad-            found_ev <- mb_solved `mplus` mb_inert--            -- We're about to "solve" the wanted we're looking up, so we-            -- must make sure doing so wouldn't run afoul of-            -- Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance.-            -- Forgetting this led to #20666.-            guard $ not (prohibitedSuperClassSolve (ctEvLoc found_ev) loc)--            return found_ev }-  | otherwise -- NB: No caching for equalities, IPs, holes, or errors-  = return Nothing---- | Look up a dictionary inert.-lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe DictCt-lookupInertDict (IC { inert_dicts = dicts }) loc cls tys-  = findDict dicts loc cls tys---- | 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-  = fmap dictCtEvidence (findDict solved loc cls tys)------------------------------lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction)-lookupFamAppCache fam_tc tys-  = do { IS { inert_famapp_cache = famapp_cache } <- getInertSet-       ; case findFunEq famapp_cache fam_tc tys of-           result@(Just redn) ->-             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)-                                                    , ppr redn ])-                ; return result }-           Nothing -> return Nothing }--extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS ()--- NB: co :: rhs ~ F tys, to match expectations of rewriter-extendFamAppCache tc xi_args stuff@(Reduction _ ty)-  = do { dflags <- getDynFlags-       ; when (gopt Opt_FamAppCache dflags) $-    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args-                                            , ppr ty ])-       ; updInertSet $ \ 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-  = updInertSet (\inerts@(IS { inert_famapp_cache = famapp_cache }) ->-                   inerts { inert_famapp_cache = filterTcAppMap check famapp_cache })-  where-    check :: Reduction -> Bool-    check redn-      = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn)--{--************************************************************************-*                                                                      *-*              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, so it-         -- could equally well be a Bool instead of an Int.--      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--      -- Whether to throw an exception if we come across an insoluble constraint.-      -- Used to fail-fast when checking for hole-fits. See Note [Speeding up-      -- valid hole-fits].-      tcs_abort_on_insoluble :: Bool,--      -- 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)--instance MonadFix TcS where-  mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env)---- | 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 MonadIO TcS where-  liftIO act = TcS $ \_env -> liftIO act--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--liftZonkTcS :: ZonkM a -> TcS a-liftZonkTcS = wrapTcS . TcM.liftZonkM--wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a-wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env)--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--panicTcS  :: SDoc -> TcS a-failTcS   :: TcRnMessage -> TcS a-warnTcS, addErrTcS :: TcRnMessage -> TcS ()-failTcS      = wrapTcS . TcM.failWith-warnTcS msg  = wrapTcS (TcM.addDiagnostic msg)-addErrTcS    = wrapTcS . TcM.addErr-panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc--tryEarlyAbortTcS :: TcS ()--- Abort (fail in the monad) if the abort_on_insoluble flag is on-tryEarlyAbortTcS-  = mkTcS (\env -> when (tcs_abort_on_insoluble env) TcM.failM)---- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'.-ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS ()-ctLocWarnTcS loc msg = wrapTcS $ TcM.setCtLocM loc $ TcM.addDiagnostic msg--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 = wrapTcS . runTcPluginM--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 { logger <- getLogger-       ; when (  logHasDumpFlag logger Opt_D_dump_cs_trace-                  || logHasDumpFlag logger Opt_D_dump_tc_trace)-              ( 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 immediately fail upon encountering an--- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage--- site does not need the ev_binds, so we do not return them.-runTcSEarlyAbort :: TcS a -> TcM a-runTcSEarlyAbort tcs-  = do { ev_binds_var <- TcM.newTcEvBinds-       ; runTcSWithEvBinds' True True 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 False ev_binds_var $ do-    setInertSet inerts-    a <- tcs-    new_inerts <- getInertSet-    return (a, new_inerts)--runTcSWithEvBinds :: EvBindsVar-                  -> TcS a-                  -> TcM a-runTcSWithEvBinds = runTcSWithEvBinds' True False--runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?-                           -- Don't if you want to reuse the InertSet.-                           -- See also Note [Type equality cycles]-                           -- in GHC.Tc.Solver.Equality-                   -> Bool-                   -> EvBindsVar-                   -> TcS a-                   -> TcM a-runTcSWithEvBinds' restore_cycles abort_on_insoluble 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_abort_on_insoluble = abort_on_insoluble-                          , 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-                   , tcs_abort_on_insoluble = abort_on_insoluble-                   } ->-    do { inerts <- TcM.readTcRef old_inert_var-       ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack-                                                            (inert_cycle_breakers inerts)-                                 , 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_abort_on_insoluble = abort_on_insoluble-                               , 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 -> SkolemInfoAnon-                   -> [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 -> SkolemInfoAnon-                     -> [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--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--getUnifiedRef :: TcS (IORef Int)-getUnifiedRef = TcS (return . tcs_unified)---- Getter of inerts and worklist-getInertSetRef :: TcS (IORef InertSet)-getInertSetRef = TcS (return . tcs_inerts)--getInertSet :: TcS InertSet-getInertSet = getInertSetRef >>= readTcRef--setInertSet :: InertSet -> TcS ()-setInertSet is = do { r <- getInertSetRef; writeTcRef r is }--getTcSWorkListRef :: TcS (IORef WorkList)-getTcSWorkListRef = TcS (return . tcs_worklist)--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 (listToBag (map mkNonCanonical evs))--emitWork :: Cts -> TcS ()-emitWork cts-  | isEmptyBag cts    -- Avoid printing, among other work-  = return ()-  | otherwise-  = do { traceTcS "Emitting fresh work" (pprBag cts)-         -- Zonk the rewriter set of Wanteds, because that affects-         -- the prioritisation of the work-list. Suppose a constraint-         -- c1 is rewritten by another, c2.  When c2 gets solved,-         -- c1 has no rewriters, and can be prioritised; see-         -- Note [Prioritise Wanteds with empty RewriterSet]-         -- in GHC.Tc.Types.Constraint wrinkle (WRW1)-       ; cts <- wrapTcS $ mapBagM TcM.zonkCtRewriterSet 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.liftZonkM $ TcM.writeMetaTyVar tv ty-       ; TcM.updTcRef (tcs_unified env) (+1) }--reportUnifications :: TcS a -> TcS (Int, a)--- Record how many unifications are done by thing_inside--- We could return a Bool instead of an Int;--- all that matters is whether it is no-zero-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 (DefaultEnv, 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.Dict.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--setSrcSpan :: RealSrcSpan -> TcS a -> TcS a-setSrcSpan ss = wrap2TcS (TcM.setSrcSpan (RealSrcSpan ss mempty))--tcLookupClass :: Name -> TcS Class-tcLookupClass c = wrapTcS $ TcM.tcLookupClass c--tcLookupId :: Name -> TcS Id-tcLookupId n = wrapTcS $ TcM.tcLookupId n--tcLookupTyCon :: Name -> TcS TyCon-tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyCon n---- Any use of this function is a bit suspect, because it violates the--- pure veneer of TcS. But it's just about warnings around unused imports--- and local constructors (GHC will issue fewer warnings than it otherwise--- might), so it's not worth losing sleep over.-recordUsedGREs :: Bag GlobalRdrElt -> TcS ()-recordUsedGREs gres-  = do { wrapTcS $ TcM.addUsedGREs NoDeprecationWarnings gre_list-         -- If a newtype constructor was imported, don't warn about not-         -- importing it...-       ; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list }-         -- ...and similarly, if a newtype constructor was defined in the same-         -- module, don't warn about it being unused.-         -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.--  where-    gre_list = bagToList gres---- 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-  = do-      mbind_lvl <- checkWellStagedInstanceWhat what-      case mbind_lvl of-        Just bind_lvl | bind_lvl > impLevel ->-          wrapTcS $ TcM.setCtLocM loc $ do-              { use_stage <- TcM.getStage-              ; TcM.checkWellStaged (StageCheckInstance what pred) bind_lvl (thLevel use_stage) }-        _ ->-          return ()---- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)--- See Note [Well-staged instance evidence]-checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe ThLevel)-checkWellStagedInstanceWhat what-  | TopLevInstance { iw_dfun_id = dfun_id } <- what-    = return $ Just (TcM.topIdLvl dfun_id)-  | BuiltinTypeableInstance tc <- what-    = do-        cur_mod <- extractModule <$> getGblEnv-        return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc)-                        then outerLevel-                        else impLevel)-  | otherwise = return Nothing--{--Note [Well-staged instance evidence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Evidence for instances must obey the same level restrictions as normal bindings.-In particular, it is forbidden to use an instance in a top-level splice in the-module which the instance is defined. This is because the evidence is bound at-the top-level and top-level definitions are forbidden from being using in top-level splices in-the same module.--For example, suppose you have a function..  foo :: Show a => Code Q a -> Code Q ()-then the following program is disallowed,--```-data T a = T a deriving (Show)--main :: IO ()-main =-  let x = $$(foo [|| T () ||])-  in return ()-```--because the `foo` function (used in a top-level splice) requires `Show T` evidence,-which is defined at the top-level and therefore fails with an error that we have violated-the stage restriction.--```-Main.hs:12:14: error:-    • GHC stage restriction:-        instance for ‘Show-                        (T ())’ is used in a top-level splice, quasi-quote, or annotation,-        and must be imported, not defined locally-    • In the expression: foo [|| T () ||]-      In the Template Haskell splice $$(foo [|| T () ||])-      In the expression: $$(foo [|| T () ||])-   |-12 |   let x = $$(foo [|| T () ||])-   |-```--Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on-`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT`-is well staged.  It's easy to know the stage of `$tcT`: for imported TyCons it-will be `impLevel`, and for local TyCons it will be `toplevel`.--Therefore the `InstanceWhat` type had to be extended with-a special case for `Typeable`, which recorded the TyCon the evidence was for and-could them be used to check that we were not attempting to evidence in a stage incorrect-manner.---}--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)--isUnfilledMetaTyVar :: TcTyVar -> TcS Bool-isUnfilledMetaTyVar tv = wrapTcS $ TcM.isUnfilledMetaTyVar tv--zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet-zonkTyCoVarsAndFV tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFV tvs)--zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]-zonkTyCoVarsAndFVList tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFVList tvs)--zonkCo :: Coercion -> TcS Coercion-zonkCo = wrapTcS . fmap TcM.liftZonkM TcM.zonkCo--zonkTcType :: TcType -> TcS TcType-zonkTcType ty = liftZonkTcS (TcM.zonkTcType ty)--zonkTcTypes :: [TcType] -> TcS [TcType]-zonkTcTypes tys = liftZonkTcS (TcM.zonkTcTypes tys)--zonkTcTyVar :: TcTyVar -> TcS TcType-zonkTcTyVar tv = liftZonkTcS (TcM.zonkTcTyVar tv)--zonkSimples :: Cts -> TcS Cts-zonkSimples cts = liftZonkTcS (TcM.zonkSimples cts)--zonkWC :: WantedConstraints -> TcS WantedConstraints-zonkWC wc = liftZonkTcS (TcM.zonkWC wc)--zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar-zonkTyCoVarKind tv = liftZonkTcS (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 is 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 [W] 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)--instFlexiX :: Subst -> [TKVar] -> TcS Subst-instFlexiX subst tvs = wrapTcS (instFlexiXTcM subst tvs)--instFlexiXTcM :: Subst -> [TKVar] -> TcM Subst--- Makes fresh tyvar, extends the substitution, and the in-scope set--- Takes account of the case [k::Type, a::k, ...],--- where we must substitute for k in a's kind-instFlexiXTcM subst []-  = return subst-instFlexiXTcM subst (tv:tvs)-  = do { uniq <- TcM.newUnique-       ; details <- TcM.newMetaDetails TauTv-       ; let name   = setNameUnique (tyVarName tv) uniq-             kind   = substTyUnchecked subst (tyVarKind tv)-             tv'    = mkTcTyVar name kind details-             subst' = extendTvSubstWithClone subst tv tv'-       ; instFlexiXTcM subst' tvs  }--matchGlobalInst :: DynFlags-                -> Bool      -- True <=> caller is the short-cut solver-                             -- See Note [Shortcut solving: overlap]-                -> Class -> [Type] -> CtLoc -> TcS TcM.ClsInstResult-matchGlobalInst dflags short_cut cls tys loc-  = wrapTcS $ TcM.setCtLocM loc $ TcM.matchGlobalInst dflags short_cut cls tys--tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar])-tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info 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 :: HasDebugCallStack => TcEvDest -> Coercion -> TcS ()-setWantedEq (HoleDest hole) co-  = do { useVars (coVarsOfCo co)-       ; fillCoercionHole hole co }-setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)---- | Good for both equalities and non-equalities-setWantedEvTerm :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS ()-setWantedEvTerm (HoleDest hole) _canonical 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 EvCanonical tm)-       ; fillCoercionHole hole (mkCoVarCo co_var) }--setWantedEvTerm (EvVarDest ev_id) canonical tm-  = setEvBind (mkWantedEvBind ev_id canonical 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 }--setEvBindIfWanted :: CtEvidence -> CanonicalEvidence -> EvTerm -> TcS ()-setEvBindIfWanted ev canonical tm-  = case ev of-      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest canonical 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 }--emitNewGivens :: CtLoc -> [(Role,TcCoercion)] -> TcS ()-emitNewGivens loc pts-  = do { traceTcS "emitNewGivens" (ppr pts)-       ; evs <- mapM (newGivenEvVar loc) $-                [ (mkPrimEqPredRole role ty1 ty2, evCoercion co)-                | (role, co) <- pts-                , let Pair ty1 ty2 = coercionKind co-                , not (ty1 `tcEqType` ty2) ] -- Kill reflexive Givens at birth-       ; emitWorkNC evs }--emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion--- | Emit a new Wanted equality into the work-list-emitNewWantedEq loc rewriters role ty1 ty2-  = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2-       ; updWorkListTcS (extendWorkListEq rewriters (mkNonCanonical ev))-       ; return co }---- | Create a new Wanted constraint holding a coercion hole--- for an equality between the two types at the given 'Role'.-newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType-            -> TcS (CtEvidence, Coercion)-newWantedEq loc rewriters role ty1 ty2-  = do { hole <- wrapTcS $ TcM.newCoercionHole loc pty-       ; return ( CtWanted { ctev_pred      = pty-                           , ctev_dest      = HoleDest hole-                           , ctev_loc       = loc-                           , ctev_rewriters = rewriters }-                , mkHoleCo hole ) }-  where-    pty = mkPrimEqPredRole role ty1 ty2---- | Create a new Wanted constraint holding an evidence variable.------ Don't use this for equality constraints: use 'newWantedEq' instead.-newWantedEvVarNC :: CtLoc -> RewriterSet-                 -> TcPredType -> TcS CtEvidence--- Don't look up in the solved/inerts; we know it's not there-newWantedEvVarNC loc rewriters 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_loc       = loc-                          , ctev_rewriters = rewriters })}---- | Like 'newWantedEvVarNC', except it might look up in the inert set--- to see if an inert already exists, and uses that instead of creating--- a new Wanted constraint.------ Don't use this for equality constraints: this function is only for--- constraints with 'EvVarDest'.-newWantedEvVar :: CtLoc -> RewriterSet-               -> TcPredType -> TcS MaybeNew--- For anything except ClassPred, this is the same as newWantedEvVarNC-newWantedEvVar loc rewriters pty-  = assertPpr (not (isEqPrimPred pty))-      (vcat [ text "newWantedEvVar: HoleDestPred"-            , text "pty:" <+> ppr pty ]) $-    do { mb_ct <- lookupInInerts loc pty-       ; case mb_ct of-            Just ctev-              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev-                    ; return $ Cached (ctEvExpr ctev) }-            _ -> do { ctev <- newWantedEvVarNC loc rewriters pty-                    ; return (Fresh ctev) } }---- | Create a new Wanted constraint, potentially looking up--- non-equality constraints in the cache instead of creating--- a new one from scratch.------ Deals with both equality and non-equality constraints.-newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew-newWanted loc rewriters pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2-  | otherwise-  = newWantedEvVar loc rewriters pty---- | Create a new Wanted constraint.------ Deals with both equality and non-equality constraints.------ Does not attempt to re-use non-equality constraints that already--- exist in the inert set.-newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence-newWantedNC loc rewriters pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = fst <$> newWantedEq loc rewriters role ty1 ty2-  | otherwise-  = newWantedEvVarNC loc rewriters pty---- | 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 (reductionDepth dflags) (ctLocDepth loc)) $-         wrapErrTcS $ solverDepthError loc ty }--matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN)-matchFam tycon args = wrapTcS $ matchFamTcM tycon args--matchFamTcM :: TyCon -> [Type] -> TcM (Maybe ReductionN)--- 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 (Reduction co ty))-      = hang (text "Match succeeded:")-          2 (vcat [ text "Rewrites to:" <+> ppr ty-                  , text "Coercion:" <+> ppr co ])--solverDepthError :: CtLoc -> TcType -> TcM a-solverDepthError loc ty-  = TcM.setCtLocM loc $-    do { (ty, env0) <- TcM.liftZonkM $-           do { ty   <- TcM.zonkTcType ty-              ; env0 <- TcM.tcInitTidyEnv-              ; return (ty, env0) }-       ; let (tidy_env, tidy_ty)  = tidyOpenTypeX env0 ty-             msg = TcRnSolverDepthError tidy_ty depth-       ; TcM.failWithTcM (tidy_env, msg) }-  where-    depth = ctLocDepth loc--{--************************************************************************-*                                                                      *-              Emitting equalities arising from fundeps-*                                                                      *-************************************************************************--}--emitFunDepWanteds :: CtEvidence  -- The work item-                  -> [FunDepEqn (CtLoc, RewriterSet)]-                  -> TcS Bool  -- True <=> some unification happened--emitFunDepWanteds _ [] = return False -- common case noop--- See Note [FunDep and implicit parameter reactions]--emitFunDepWanteds ev fd_eqns-  = unifyFunDeps ev Nominal do_fundeps-  where-    do_fundeps :: UnifyEnv -> TcM ()-    do_fundeps env = mapM_ (do_one env) fd_eqns--    do_one :: UnifyEnv -> FunDepEqn (CtLoc, RewriterSet) -> TcM ()-    do_one uenv (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) })-      = do { eqs' <- instantiate_eqs tvs (reverse eqs)-                     -- (reverse eqs): See Note [Reverse order of fundep equations]-           ; uPairsTcM env_one eqs' }-      where-        env_one = uenv { u_rewriters = u_rewriters uenv S.<> rewriters-                       , u_loc       = loc }--    instantiate_eqs :: [TyVar] -> [TypeEqn] -> TcM [TypeEqn]-    instantiate_eqs tvs eqs-      | null tvs-      = return eqs-      | otherwise-      = do { TcM.traceTc "emitFunDepWanteds 2" (ppr tvs $$ ppr eqs)-           ; subst <- instFlexiXTcM emptySubst tvs  -- Takes account of kind substitution-           ; return [ Pair (substTyUnchecked subst' ty1) ty2-                           -- ty2 does not mention fd_qtvs, so no need to subst it.-                           -- See GHC.Tc.Instance.Fundeps Note [Improving against instances]-                           --     Wrinkle (1)-                    | Pair ty1 ty2 <- eqs-                    , let subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1) ]-                          -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result-                          -- of matching with the [W] constraint. So we add its free-                          -- vars to InScopeSet, to satisfy substTy's invariants, even-                          -- though ty1 will never (currently) be a poytype, so this-                          -- InScopeSet will never be looked at.-           }--{--************************************************************************-*                                                                      *-              Unification-*                                                                      *-************************************************************************--Note [wrapUnifierTcS]-~~~~~~~~~~~~~~~~~~~-When decomposing equalities we often create new wanted constraints for-(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.--Rather than making an equality test (which traverses the structure of the type,-perhaps fruitlessly), we call uType (via wrapUnifierTcS) to traverse the common-structure, and bales out when it finds a difference by creating a new deferred-Wanted constraint.  But where it succeeds in finding common structure, it just-builds a coercion to reflect it.--This is all much faster than creating a new constraint, putting it in the-work list, picking it out, canonicalising it, etc etc.--Note [unifyFunDeps]-~~~~~~~~~~~~~~~~~~~-The Bool returned by `unifyFunDeps` is True if we have unified a variable-that occurs in the constraint we are trying to solve; it is not in the-inert set so `wrapUnifierTcS` won't kick it out.  Instead we want to send it-back to the start of the pipeline.  Hence the Bool.--It's vital that we don't return (not (null unified)) because the fundeps-may create fresh variables; unifying them (alone) should not make us send-the constraint back to the start, or we'll get an infinite loop.  See-Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict-and Note [Improvement orientation] in GHC.Tc.Solver.Equality.--}--uPairsTcM :: UnifyEnv -> [TypeEqn] -> TcM ()-uPairsTcM uenv eqns = mapM_ (\(Pair ty1 ty2) -> uType uenv ty1 ty2) eqns--unifyFunDeps :: CtEvidence -> Role-             -> (UnifyEnv -> TcM ())-             -> TcS Bool-unifyFunDeps ev role do_unifications-  = do { (_, _, unified) <- wrapUnifierTcS ev role do_unifications-       ; return (any (`elemVarSet` fvs) unified) }-         -- See Note [unifyFunDeps]-  where-    fvs = tyCoVarsOfType (ctEvPred ev)--unifyForAllBody :: CtEvidence -> Role -> (UnifyEnv -> TcM a)-                -> TcS (a, Cts)--- We /return/ the equality constraints we generate,--- rather than emitting them into the monad.--- See See (SF5) in Note [Solving forall equalities] in GHC.Tc.Solver.Equality-unifyForAllBody ev role unify_body-  = do { (res, cts, unified, _rewriters) <- wrapUnifierX ev role unify_body-         -- Ignore the rewriters. They are used in wrapUnifierTcS only-         -- as an optimistion to prioritise the work list; but they are-         -- /also/ stored in each individual constraint we return.--       -- Kick out any inert constraint that we have unified-       ; _ <- kickOutAfterUnification unified--       ; return (res, cts) }--wrapUnifierTcS :: CtEvidence -> Role-               -> (UnifyEnv -> TcM a)  -- Some calls to uType-               -> TcS (a, Bag Ct, [TcTyVar])--- Invokes the do_unifications argument, with a suitable UnifyEnv.--- Emit deferred equalities and kick-out from the inert set as a--- result of any unifications.--- Very good short-cut when the two types are equal, or nearly so--- See Note [wrapUnifierTcS]------ The [TcTyVar] is the list of unification variables that were--- unified the process; the (Bag Ct) are the deferred constraints.--wrapUnifierTcS ev role do_unifications-  = do { (res, cts, unified, rewriters) <- wrapUnifierX ev role do_unifications--       -- Emit the deferred constraints-       -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality-       ---       -- All the constraints in `cts` share the same rewriter set so,-       -- rather than looking at it one by one, we pass it to-       -- extendWorkListEqs; just a small optimisation.-       ; unless (isEmptyBag cts) $-         updWorkListTcS (extendWorkListEqs rewriters cts)--       -- And kick out any inert constraint that we have unified-       ; _ <- kickOutAfterUnification unified--       ; return (res, cts, unified) }--wrapUnifierX :: CtEvidence -> Role-             -> (UnifyEnv -> TcM a)  -- Some calls to uType-             -> TcS (a, Bag Ct, [TcTyVar], RewriterSet)-wrapUnifierX ev role do_unifications-  = do { unif_count_ref <- getUnifiedRef-       ; wrapTcS $-         do { defer_ref   <- TcM.newTcRef emptyBag-            ; unified_ref <- TcM.newTcRef []-            ; rewriters   <- TcM.zonkRewriterSet (ctEvRewriters ev)-            ; let env = UE { u_role      = role-                           , u_rewriters = rewriters-                           , u_loc       = ctEvLoc ev-                           , u_defer     = defer_ref-                           , u_unified   = Just unified_ref}--            ; res <- do_unifications env--            ; cts     <- TcM.readTcRef defer_ref-            ; unified <- TcM.readTcRef unified_ref--            -- Don't forget to update the count of variables-            -- unified, lest we forget to iterate (#24146)-            ; unless (null unified) $-              TcM.updTcRef unif_count_ref (+ (length unified))--            ; return (res, cts, unified, rewriters) } }---{--************************************************************************-*                                                                      *-              Breaking type variable cycles-*                                                                      *-************************************************************************--}--checkTouchableTyVarEq-   :: CtEvidence-   -> TcTyVar    -- A touchable meta-tyvar-   -> TcType     -- The RHS-   -> TcS (PuResult () Reduction)--- Used for Nominal, Wanted equalities, with a touchable meta-tyvar on LHS--- If checkTouchableTyVarEq tv ty = PuOK cts redn---   then we can unify---       tv := ty |> redn---   with extra wanteds 'cts'--- If it returns (PuFail reason) we can't unify, and the reason explains why.-checkTouchableTyVarEq ev lhs_tv rhs-  | simpleUnifyCheck UC_Solver lhs_tv rhs   -- An (optional) short-cut-  = do { traceTcS "checkTouchableTyVarEq: simple-check wins" (ppr lhs_tv $$ ppr rhs)-       ; return (pure (mkReflRedn Nominal rhs)) }--  | otherwise-  = do { traceTcS "checkTouchableTyVarEq {" (ppr lhs_tv $$ ppr rhs)-       ; check_result <- wrapTcS (check_rhs rhs)-       ; traceTcS "checkTouchableTyVarEq }" (ppr lhs_tv $$ ppr check_result)-       ; case check_result of-            PuFail reason -> return (PuFail reason)-            PuOK cts redn -> do { emitWork cts-                                ; return (pure redn) } }--  where-    (lhs_tv_info, lhs_tv_lvl) = case tcTyVarDetails lhs_tv of-       MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info,lvl)-       _ -> pprPanic "checkTouchableTyVarEq" (ppr lhs_tv)-            -- lhs_tv should be a meta-tyvar--    is_concrete_lhs_tv = isConcreteInfo lhs_tv_info--    check_rhs rhs-       -- Crucial special case for  alpha ~ F tys-       -- We don't want to flatten that (F tys)!-       | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs-       = if is_concrete_lhs_tv-         then failCheckWith (cteProblem cteConcrete)-         else recurseIntoTyConApp arg_flags tc tys-       | otherwise-       = checkTyEqRhs flags rhs--    flags = TEF { tef_foralls  = False -- isRuntimeUnkSkol lhs_tv-                , tef_fam_app  = mkTEFA_Break ev NomEq break_wanted-                , tef_unifying = Unifying lhs_tv_info lhs_tv_lvl (LC_Promote False)-                , tef_lhs      = TyVarLHS lhs_tv-                , tef_occurs   = cteInsolubleOccurs }--    arg_flags = famAppArgFlags flags--    break_wanted :: FamAppBreaker Ct-    break_wanted fam_app-      -- Occurs check or skolem escape; so flatten-      = do { let fam_app_kind = typeKind fam_app-           ; reason <- checkPromoteFreeVars cteInsolubleOccurs-                            lhs_tv lhs_tv_lvl (tyCoVarsOfType fam_app_kind)-           ; if not (cterHasNoProblem reason)  -- Failed to promote free vars-             then failCheckWith reason-             else-        do { new_tv_ty <--              case lhs_tv_info of-                ConcreteTv conc_info ->-                  -- Make a concrete tyvar if lhs_tv is concrete-                  -- e.g.  alpha[2,conc] ~ Maybe (F beta[4])-                  --       We want to flatten to-                  --       alpha[2,conc] ~ Maybe gamma[2,conc]-                  --       gamma[2,conc] ~ F beta[4]-                  TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind-                _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind--           ; let pty = mkPrimEqPredRole Nominal fam_app new_tv_ty-           ; hole <- TcM.newVanillaCoercionHole pty-           ; let new_ev = CtWanted { ctev_pred      = pty-                                   , ctev_dest      = HoleDest hole-                                   , ctev_loc       = cb_loc-                                   , ctev_rewriters = ctEvRewriters ev }-           ; return (PuOK (singleCt (mkNonCanonical new_ev))-                          (mkReduction (HoleCo hole) new_tv_ty)) } }--    -- See Detail (7) of the Note-    cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin---------------------------checkTypeEq :: CtEvidence -> EqRel -> CanEqLHS -> TcType-            -> TcS (PuResult () Reduction)--- Used for general CanEqLHSs, ones that do--- not have a touchable type variable on the LHS (i.e. not unifying)-checkTypeEq ev eq_rel lhs rhs-  | isGiven ev-  = do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs-                                        , text "rhs:" <+> ppr rhs ])-       ; check_result <- wrapTcS (check_given_rhs rhs)-       ; traceTcS "checkTypeEq }" (ppr check_result)-       ; case check_result of-            PuFail reason -> return (PuFail reason)-            PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs-                                ; emitWork new_givens-                                ; updInertSet (addCycleBreakerBindings prs)-                                ; return (pure redn) } }--  | otherwise  -- Wanted-  = do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs)-       ; case check_result of-            PuFail reason -> return (PuFail reason)-            PuOK cts redn -> do { emitWork cts-                                ; return (pure redn) } }-  where-    check_given_rhs :: TcType -> TcM (PuResult (TcTyVar,TcType) Reduction)-    check_given_rhs rhs-       -- See Note [Special case for top-level of Given equality]-       | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs-       = recurseIntoTyConApp arg_flags tc tys-       | otherwise-       = checkTyEqRhs given_flags rhs--    arg_flags = famAppArgFlags given_flags--    given_flags :: TyEqFlags (TcTyVar,TcType)-    given_flags = TEF { tef_lhs      = lhs-                      , tef_foralls  = False-                      , tef_unifying = NotUnifying-                      , tef_fam_app  = mkTEFA_Break ev eq_rel break_given-                      , tef_occurs   = occ_prob }-        -- TEFA_Break used for: [G] a ~ Maybe (F a)-        --                   or [W] F a ~ Maybe (F a)--    wanted_flags = TEF { tef_lhs      = lhs-                       , tef_foralls  = False-                       , tef_unifying = NotUnifying-                       , tef_fam_app  = TEFA_Recurse-                       , tef_occurs   = occ_prob }-        -- TEFA_Recurse: see Note [Don't cycle-break Wanteds when not unifying]--    -- occ_prob: see Note [Occurs check and representational equality]-    occ_prob = case eq_rel of-                 NomEq  -> cteInsolubleOccurs-                 ReprEq -> cteSolubleOccurs--    break_given :: TcType -> TcM (PuResult (TcTyVar,TcType) Reduction)-    break_given fam_app-      = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app)-           ; return (PuOK (unitBag (new_tv, fam_app))-                          (mkReflRedn Nominal (mkTyVarTy new_tv))) }-                    -- Why reflexive? See Detail (4) of the Note--    ----------------------------    mk_new_given :: (TcTyVar, TcType) -> TcS Ct-    mk_new_given (new_tv, fam_app)-      = mkNonCanonical <$> newGivenEvVar cb_loc (given_pred, given_term)-      where-        new_ty     = mkTyVarTy new_tv-        given_pred = mkPrimEqPred fam_app new_ty-        given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note--    -- See Detail (7) of the Note-    cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin--mkTEFA_Break :: CtEvidence -> EqRel -> FamAppBreaker a -> TyEqFamApp a-mkTEFA_Break ev eq_rel breaker-  | NomEq <- eq_rel-  , not cycle_breaker_origin-  = TEFA_Break breaker-  | otherwise-  = TEFA_Recurse-  where-    -- cycle_breaker_origin: see Detail (7) of Note [Type equality cycles]-    -- in GHC.Tc.Solver.Equality-    cycle_breaker_origin = case ctLocOrigin (ctEvLoc ev) of-                              CycleBreakerOrigin {} -> True-                              _                     -> False------------------------------ | Fill in CycleBreakerTvs with the variables they stand for.--- See Note [Type equality cycles] in GHC.Tc.Solver.Equality-restoreTyVarCycles :: InertSet -> TcM ()-restoreTyVarCycles is-  = TcM.liftZonkM-  $ forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar-{-# SPECIALISE forAllCycleBreakerBindings_ ::-      CycleBreakerVarStack -> (TcTyVar -> TcType -> ZonkM ()) -> ZonkM () #-}---{- Note [Occurs check and representational equality]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(a ~R# b a) is soluble if b later turns out to be Identity-So we treat this as a "soluble occurs check".--Note [Special case for top-level of Given equality]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We take care when examining-    [G] F ty ~ G (...(F ty)...)-where both sides are TyFamLHSs.  We don't want to flatten that RHS to-    [G] F ty ~ cbv-    [G] G (...(F ty)...) ~ cbv-Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a-canonical constraint-    [G] G (...(F ty)...) ~ F ty-That tents to rewrite a big type to smaller one. This happens in T15703,-where we had:-    [G] Pure g ~ From1 (To1 (Pure g))-Making a loop breaker and rewriting left to right just makes much bigger-types than swapping it over.--(We might hope to have swapped it over before getting to checkTypeEq,-but better safe than sorry.)--NB: We never see a TyVarLHS here, such as-    [G] a ~ F tys here-because we'd have swapped it to-   [G] F tys ~ a-in canEqCanLHS2, before getting to checkTypeEq.+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Monadic definitions for the constraint solver+module GHC.Tc.Solver.Monad (++    -- The TcS monad+    TcS(..), TcSEnv(..),+    runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,+    failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS,+    runTcSEqualities,+    nestTcS, nestImplicTcS, tryShortCutTcS,+    setEvBindsTcS, setTcLevelTcS,+    emitFunDepWanteds,++    selectNextWorkItem,+    getWorkList,+    updWorkListTcS,+    pushLevelNoWorkList,++    runTcPluginTcS, recordUsedGREs,+    matchGlobalInst, TcM.ClsInstResult(..),++    QCInst(..),++    -- TcSMode+    TcSMode(..), getTcSMode, setTcSMode, vanillaTcSMode,++    -- The pipeline+    StopOrContinue(..), continueWith, stopWith,+    startAgainWith, SolverStage(Stage, runSolverStage), simpleStage,+    stopWithStage, nopStage,++    -- Tracing etc+    panicTcS, traceTcS, tryEarlyAbortTcS,+    traceFireTcS, bumpStepCountTcS, csTraceTcS,+    wrapErrTcS, wrapWarnTcS,+    resetUnificationFlag, setUnificationFlag,++    -- Evidence creation and transformation+    MaybeNew(..), freshGoals, isFresh, getEvExpr,+    CanonicalEvidence(..),++    newTcEvBinds, newNoTcEvBinds,+    newWantedEq, emitNewWantedEq,+    newWanted,+    newWantedNC, newWantedEvVarNC,+    newBoundEvVarId,+    unifyTyVar, reportUnifications,+    setEvBind, setWantedEq,+    setWantedEvTerm, setEvBindIfWanted,+    newEvVar, newGivenEvVar, emitNewGivens,+    checkReductionDepth,++    getInstEnvs, getFamInstEnvs,                -- Getting the environments+    getTopEnv, getGblEnv, getLclEnv, setSrcSpan,+    getTcEvBindsVar, getTcLevel,+    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,+    tcLookupClass, tcLookupId, tcLookupTyCon,++    getUnifiedRef,+++    -- Inerts+    updInertSet, updInertCans,+    getHasGivenEqs, setInertCans,+    getInertEqs, getInertCans, getInertGivens,+    getInertInsols, getInnermostGivenEqLevel,+    getInertSet, setInertSet,+    getUnsolvedInerts,+    removeInertCts, getPendingGivenScs,+    insertFunEq, addInertQCI,+    updInertDicts, updInertIrreds,+    emitWorkNC, emitWork,+    lookupInertDict,++    -- The Model+    kickOutAfterUnification, kickOutRewritable,++    -- Inert Safe Haskell safe-overlap failures+    insertSafeOverlapFailureTcS,+    getSafeOverlapFailures,++    -- Inert solved dictionaries+    getSolvedDicts, setSolvedDicts,+    updSolvedDicts, lookupSolvedDict,++    -- Irreds+    foldIrreds,++    -- The family application cache+    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,+    pprKicked,++    -- Instantiation+    instDFunType,++    -- Unification+    wrapUnifierX, wrapUnifierTcS, unifyFunDeps, uPairsTcM, unifyForAllBody,++    -- MetaTyVars+    newFlexiTcSTy, instFlexiX,+    cloneMetaTyVar,+    tcInstSkolTyVarsX,++    TcLevel,+    isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,+    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,+    zonkTyCoVarsAndFVList,+    zonkSimples, zonkWC,+    zonkTyCoVarKind,++    -- References+    newTcRef, readTcRef, writeTcRef, updTcRef,++    -- Misc+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,+    matchFam, matchFamTcM,+    checkWellLevelledDFun,+    pprEq,++    -- Enforcing invariants for type equalities+    checkTypeEq+) 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+       ( tcGetDefaultTys+       , tcLookupClass, tcLookupId, tcLookupTyCon+       )+import GHC.Tc.Zonk.Monad ( ZonkM )+import qualified GHC.Tc.Zonk.TcType  as TcM++import GHC.Driver.DynFlags++import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon )+import GHC.Tc.Instance.FunDeps( FunDepEqn(..) )+import GHC.Utils.Misc+++import GHC.Tc.Solver.Types+import GHC.Tc.Solver.InertSet+import GHC.Tc.Errors.Types++import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Unify++import GHC.Tc.Types.Evidence+import GHC.Tc.Types+import GHC.Tc.Types.Origin+import GHC.Tc.Types.CtLoc+import GHC.Tc.Types.Constraint++import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName )++import GHC.Core.Type+import GHC.Core.TyCo.Rep as Rep+import GHC.Core.TyCo.Tidy+import GHC.Core.Coercion+import GHC.Core.Coercion.Axiom( TypeEqn )+import GHC.Core.Predicate+import GHC.Core.Reduction+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.Unify (typesAreApart)++import GHC.Types.Name+import GHC.Types.TyThing+import GHC.Types.Name.Reader+import GHC.Types.DefaultEnv ( DefaultEnv )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Unique.Supply+import GHC.Types.Unique.Set( elementOfUniqSet )+import GHC.Types.Id+import GHC.Types.Basic (allImportLevels)+import GHC.Types.ThLevelIndex (thLevelIndexFromImportLevel)+import GHC.Types.SrcLoc++import GHC.Unit.Module+import qualified GHC.Rename.Env as TcM+import GHC.Rename.Env++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger++import GHC.Data.Bag as Bag+import GHC.Data.Pair++import GHC.Utils.Monad++import GHC.Exts (oneShot)+import Control.Monad+import Data.Foldable hiding ( foldr1 )+import Data.IORef+import Data.Maybe( catMaybes )+import Data.List ( mapAccumL )+import Data.List.NonEmpty ( nonEmpty )+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup as S+import GHC.LanguageExtensions as LangExt++#if defined(DEBUG)+import GHC.Types.Unique.Set (nonDetEltsUniqSet)+import GHC.Data.Graph.Directed+#endif++import qualified Data.Set as Set+import GHC.Unit.Module.Graph++{- *********************************************************************+*                                                                      *+               SolverStage and StopOrContinue+*                                                                      *+********************************************************************* -}++{- Note [The SolverStage monad]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The SolverStage monad allows us to write simple code like that in+GHC.Tc.Solver.solveEquality.   At the time of writing it looked like+this (may get out of date but the idea is clear):++solveEquality :: ... -> SolverStage Void+solveEquality ev eq_rel ty1 ty2+  = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2+       ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2'+       ; case mb_canon of {+            Left irred_ct -> do { tryQCsIrredEqCt irred_ct+                                ; solveIrred irred_ct } ;+            Right eq_ct   -> do { tryInertEqs eq_ct+                                ; tryFunDeps  eq_ct+                                ; tryQCsEqCt  eq_ct+                                ; simpleStage (updInertEqs eq_ct)+                                ; stopWithStage (eqCtEvidence eq_ct) ".." }}}++Each sub-stage can elect to+  (a) ContinueWith: continue to the next stasge+  (b) StartAgain:   start again at the beginning of the pipeline+  (c) Stop:         stop altogether; constraint is solved++These three possiblities are described by the `StopOrContinue` data type.+The `SolverStage` monad does the plumbing.++Notes:++(SM1) Each individual stage pretty quickly drops down into+         TcS (StopOrContinue a)+    because the monadic plumbing of `SolverStage` is relatively ineffienct,+    with that three-way split.++(SM2) We use `SolverStage Void` to express the idea that ContinueWith is+    impossible; we don't need to pattern match on it as a possible outcome:A+    see GHC.Tc.Solver.Solve.solveOne.   To that end, ContinueWith is strict.+-}++data StopOrContinue a+  = StartAgain Ct     -- Constraint is not solved, but some unifications+                      --   happened, so go back to the beginning of the pipeline++  | ContinueWith !a   -- The constraint was not solved, although it may have+                      --   been rewritten.  It is strict so that+                      --   ContinueWith Void can't happen; see (SM2) in+                      --   Note [The SolverStage monad]++  | Stop CtEvidence   -- The (rewritten) constraint was solved+         SDoc         -- Tells how it was solved+                      -- Any new sub-goals have been put on the work list+  deriving (Functor)++instance Outputable a => Outputable (StopOrContinue a) where+  ppr (Stop ev s)      = text "Stop" <> parens (s $$ text "ev:" <+> ppr ev)+  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w+  ppr (StartAgain w)   = text "StartAgain" <+> ppr w++newtype SolverStage a = Stage { runSolverStage :: TcS (StopOrContinue a) }+  deriving( Functor )++instance Applicative SolverStage where+  pure x = Stage (return (ContinueWith x))+  (<*>)  = ap++instance Monad SolverStage where+  return          = pure+  (Stage m) >>= k = Stage $+                    do { soc <- m+                       ; case soc of+                           StartAgain x   -> return (StartAgain x)+                           Stop ev d      -> return (Stop ev d)+                           ContinueWith x -> runSolverStage (k x) }++nopStage :: a -> SolverStage a+nopStage res = Stage (continueWith res)++simpleStage :: TcS a -> SolverStage a+-- Always does a ContinueWith; no Stop or StartAgain+simpleStage thing = Stage (do { res <- thing; continueWith res })++startAgainWith :: Ct -> TcS (StopOrContinue a)+startAgainWith ct = return (StartAgain ct)++continueWith :: a -> TcS (StopOrContinue a)+continueWith ct = return (ContinueWith ct)++stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)+stopWith ev s = return (Stop ev (text s))++stopWithStage :: CtEvidence -> String -> SolverStage a+stopWithStage ev s = Stage (stopWith ev s)+++{- *********************************************************************+*                                                                      *+                   Inert instances: inert_qcis+*                                                                      *+********************************************************************* -}++addInertQCI :: QCInst -> TcS ()+-- Add a local quantified constraint, typically arising from a type signature+addInertQCI new_qci+  = do { ics  <- getInertCans+       ; ics1 <- add_qci ics++       -- Update given equalities. C.f updateGivenEqs+       ; tclvl <- getTcLevel+       ; let body_pred    = qci_body new_qci+             not_equality = isClassPred body_pred && not (isEqClassPred body_pred)+                  -- True <=> definitely not an equality+                  -- A qci_body 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_qcis = 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_qcis = 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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As an optimisation, we avoid adding duplicate quantified instances to the+inert set; we use a simple duplicate check using tcEqType for simplicity,+even though it doesn't account for superficial differences, e.g. it will count+the following two constraints as different (#22223):++  - forall a b. C a b+  - forall b a. C a b++The main logic that allows us to pick local instances, even in the presence of+duplicates, is explained in Note [Use only the best matching quantified constraint]+in GHC.Tc.Solver.Dict.+-}++updInertDicts :: DictCt -> TcS ()+updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })+  = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls  <+> ppr tys)++       ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys+            -> -- For [G] ?x::ty, remove any dicts mentioning ?x,+              --    from /both/ inert_cans /and/ inert_solved_dicts (#23761)+               -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]+               updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->+               inerts { inert_cans         = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics+                      , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }+            | otherwise+            -> return ()+       -- Add the new constraint to the inert set+       ; updInertCans (updDicts (addDict dict_ct)) }+  where+    -- Does this class constraint or any of its superclasses mention+    -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?+    does_not_mention_ip_for :: Type -> DictCt -> Bool+    does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })+      = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys+        -- See Note [Using typesAreApart when calling mightMentionIP]+        -- in GHC.Core.Predicate++updInertIrreds :: IrredCt -> TcS ()+updInertIrreds irred+  = do { tc_lvl <- getTcLevel+       ; updInertCans $ addIrredToCans tc_lvl irred }++{- *********************************************************************+*                                                                      *+                  Kicking out+*                                                                      *+************************************************************************+-}+++-----------------------------------------+kickOutRewritable  :: KickOutSpec -> CtFlavourRole -> TcS ()+kickOutRewritable ko_spec new_fr+  = do { ics <- getInertCans+       ; let (kicked_out, ics') = kickOutRewritableLHS ko_spec new_fr ics+             n_kicked = lengthBag kicked_out+       ; setInertCans ics'++       ; unless (isEmptyBag kicked_out) $+         do { emitWork 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 = foldr add_one emptyVarSet kicked_out+                  add_one :: Ct -> VarSet -> VarSet+                  add_one ct vs | CtGiven (GivenCt { ctev_evar = ev_var }) <- ctEvidence ct+                                = vs `extendVarSet` ev_var+                                | otherwise = vs++            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&+                   -- if this isn't true, no use looking through the constraints+                    not (isEmptyVarSet kicked_given_ev_vars)) $+              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"+                            (ppr kicked_given_ev_vars)+                 ; dropFromFamAppCache kicked_given_ev_vars }++            ; csTraceTcS $+              hang (text "Kick out")+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) } }++kickOutAfterUnification :: [TcTyVar] -> TcS ()+kickOutAfterUnification tv_list = case nonEmpty tv_list of+    Nothing -> return ()+    Just tvs -> do+       { let tv_set = mkVarSet tv_list++       ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq)+                     -- Given because the tv := xi is given; NomEq because+                     -- only nominal equalities are solved by unification++       -- Set the unification flag if we have done outer unifications+       -- that might affect an earlier implication constraint+       ; let min_tv_lvl = foldr1 minTcLevel (NE.map tcTyVarLevel tvs)+       ; ambient_lvl <- getTcLevel+       ; when (ambient_lvl `strictlyDeeperThan` min_tv_lvl) $+         setUnificationFlag min_tv_lvl++       ; traceTcS "kickOutAfterUnification" (ppr tvs $$ text "n_kicked =" <+> ppr n_kicked)+       ; return n_kicked }++kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()+-- See Wrinkle (URW2) in Note [Unify only if the rewriter set is empty]+-- in GHC.Tc.Solver.Equality+--+-- It's possible that this could just go ahead and unify, but could there+-- be occurs-check problems? Seems simpler just to kick out.+kickOutAfterFillingCoercionHole hole+  = do { ics <- getInertCans+       ; let (kicked_out, ics') = kick_out ics+             n_kicked           = length kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (extendWorkListRewrittenEqs 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+    kick_out :: InertCans -> ([EqCt], InertCans)+    kick_out ics@(IC { inert_eqs = eqs })+      = (eqs_to_kick, ics { inert_eqs = eqs_to_keep })+      where+        (eqs_to_kick, eqs_to_keep) = partitionInertEqs kick_out_eq eqs++    kick_out_eq :: EqCt -> Bool    -- True: kick out; False: keep.+    kick_out_eq (EqCt { eq_ev = ev ,eq_lhs = lhs })+      | CtWanted (WantedCt { ctev_rewriters = RewriterSet rewriters }) <- ev+      , TyVarLHS tv <- lhs+      , isMetaTyVar tv+      = hole `elementOfUniqSet` rewriters+      | otherwise+      = False++--------------+insertSafeOverlapFailureTcS :: InstanceWhat -> DictCt -> TcS ()+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+insertSafeOverlapFailureTcS what item+  | safeOverlap what+  = return ()+  | otherwise+  = updInertSet (\is -> is { inert_safehask = addDict item (inert_safehask is) })++getSafeOverlapFailures :: TcS (Bag DictCt)+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+getSafeOverlapFailures+ = do { IS { inert_safehask = safehask } <- getInertSet+      ; return $ foldDicts consBag safehask emptyBag }++--------------+updSolvedDicts :: InstanceWhat -> DictCt -> TcS ()+-- Conditionally add a new item in the solved set of the monad+-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet+updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })+  | isWanted ev+  , instanceReturnsDictCon what+  = do { is_callstack    <- is_tyConTy isCallStackTy        callStackTyConName+       ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName+       ; let contains_callstack_or_exceptionCtx =+               mightMentionIP+                 (const True)+                    -- NB: the name of the call-stack IP is irrelevant+                    -- e.g (?foo :: CallStack) counts!+                 (is_callstack <||> is_exceptionCtx)+                 cls tys+       -- See Note [Don't add HasCallStack constraints to the solved set]+       ; unless contains_callstack_or_exceptionCtx $+    do { traceTcS "updSolvedDicts:" $ ppr dict_ct+       ; updInertSet $ \ ics ->+           ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) }+       } }+  | otherwise+  = return ()+  where++    -- Return a predicate that decides whether a type is CallStack+    -- or ExceptionContext, accounting for e.g. type family reduction, as+    -- per Note [Using typesAreApart when calling mightMentionIP].+    --+    -- See Note [Using isCallStackTy in mightMentionIP].+    is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)+    is_tyConTy is_eq tc_name+      = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name+           ; case mb_tc of+              Just tc ->+                return $ \ ty -> not (typesAreApart ty (mkTyConTy tc))+              Nothing ->+                return is_eq+           }++{- Note [Don't add HasCallStack constraints to the solved set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not add solved Wanted dictionaries that mention HasCallStack constraints+to the solved set, or we might fail to accumulate the proper call stack, as was+reported in #25529.++Recall that HasCallStack constraints (and the related HasExceptionContext+constraints) are implicit parameter constraints, and are accumulated as per+Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence.++When we solve a Wanted that contains a HasCallStack constraint, we don't want+to cache the result, because re-using that solution means re-using the call-stack+in a different context!++See also Note [Shadowing of implicit parameters], which deals with a similar+problem with Given implicit parameter constraints.++Note [Using isCallStackTy in mightMentionIP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To implement Note [Don't add HasCallStack constraints to the solved set],+we need to check whether a constraint contains a HasCallStack or HasExceptionContext+constraint. We do this using the 'mentionsIP' function, but as per+Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do:++  mightMentionIP+    (const True) -- (ignore the implicit parameter string)+    (isCallStackTy <||> isExceptionContextTy)++because this does not account for e.g. a type family that reduces to CallStack.+The predicate we want to use instead is:++    \ ty -> not (typesAreApart ty callStackTy && typesAreApart ty exceptionContextTy)++However, this is made difficult by the fact that CallStack and ExceptionContext+are not wired-in types; they are only known-key. This means we must look them+up using 'tcLookupTyCon'. However, this might fail, e.g. if we are in the middle+of typechecking ghc-internal and these data-types have not been typechecked yet!++In that case, we simply fall back to the naive 'isCallStackTy'/'isExceptionContextTy'+logic.++Note that it would be somewhat painful to wire-in ExceptionContext: at the time+of writing (March 2025), this would require wiring in the ExceptionAnnotation+class, as well as SomeExceptionAnnotation, which is a data type with existentials.+-}++getSolvedDicts :: TcS (DictMap DictCt)+getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) }++setSolvedDicts :: DictMap DictCt -> TcS ()+setSolvedDicts solved_dicts+  = updInertSet $ \ ics ->+    ics { inert_solved_dicts = solved_dicts }++{- *********************************************************************+*                                                                      *+                  Other inert-set operations+*                                                                      *+********************************************************************* -}++updInertSet :: (InertSet -> InertSet) -> TcS ()+-- Modify the inert set with the supplied function+updInertSet upd_fn+  = do { is_var <- getInertSetRef+       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }++getInertCans :: TcS InertCans+getInertCans = do { inerts <- getInertSet; return (inert_cans inerts) }++setInertCans :: InertCans -> TcS ()+setInertCans ics = updInertSet $ \ 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 <- getInertSetRef+       ; 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+  = updInertSet $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }++getInertEqs :: TcS InertEqs+getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }++getInnermostGivenEqLevel :: TcS TcLevel+getInnermostGivenEqLevel = do { inert <- getInertCans+                              ; return (inert_given_eq_lvl inert) }++-- | Retrieves all insoluble constraints from the inert set,+-- specifically including Given constraints.+--+-- This consists of:+--+--  - insoluble equalities, such as @Int ~# Bool@;+--  - constraints that are top-level custom type errors, of the form+--    @TypeError msg@, but not constraints such as @Eq (TypeError msg)@+--    in which the type error is nested;+--  - unsatisfiable constraints, of the form @Unsatisfiable msg@.+--+-- The inclusion of Givens is important for pattern match warnings, as we+-- want to consider a pattern match that introduces insoluble Givens to be+-- redundant (see Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver).+getInertInsols :: TcS Cts+getInertInsols+  = do { inert <- getInertCans+       ; let insols = filterBag insolubleIrredCt (inert_irreds inert)+             unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey+       ; return $ fmap CDictCan unsats `unionBags` fmap CIrredCan insols }++getInertGivens :: TcS [Ct]+-- Returns the Given constraints in the inert set+getInertGivens+  = do { inerts <- getInertCans+       ; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts)+                     $ foldDicts  ((:) . CDictCan)  (inert_dicts inerts)+                     $ foldFunEqs ((:) . CEqCan)    (inert_funeqs inerts)+                     $ foldTyEqs  ((:) . CEqCan)    (inert_eqs inerts)+                     $ []+       ; return (filter isGivenCt all_cts) }++getPendingGivenScs :: TcS [Ct]+-- Find all inert Given dictionaries, or quantified constraints, such that+--     1. cc_pend_sc flag has fuel strictly > 0+--     2. belongs to the current level+-- For each such dictionary:+-- * Return it (with unmodified cc_pend_sc) in sc_pending+-- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand+--   to record that we have expanded superclasses for this dict+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_qcis = 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_qcis = insts' })+  where+    sc_pending = sc_pend_insts ++ map CDictCan sc_pend_dicts++    sc_pend_dicts :: [DictCt]+    sc_pend_dicts = foldDicts get_pending dicts []+    dicts' = foldr exhaustAndAdd dicts sc_pend_dicts++    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts++    exhaustAndAdd :: DictCt -> DictMap DictCt -> DictMap DictCt+    exhaustAndAdd ct dicts = addDict (ct {di_pend_sc = doNotExpand}) dicts+    -- Exhaust the fuel for this constraint before adding it as+    -- we don't want to expand these constraints again++    get_pending :: DictCt -> [DictCt] -> [DictCt]  -- Get dicts with cc_pend_sc > 0+    get_pending dict dicts+        | isPendingScDictCt dict+        , belongs_to_this_level (dictCtEvidence dict)+        = dict : dicts+        | otherwise+        = dicts++    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)+    get_pending_inst cts qci@(QCI { qci_ev = ev })+       | Just qci' <- pendingScInst_maybe qci+       , belongs_to_this_level ev+       = (CQuantCan qci : cts, qci')+       -- qci' have their fuel exhausted+       -- we don't want to expand these constraints again+       -- qci is expanded+       | otherwise+       = (cts, qci)++    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) `sameDepthAs` this_lvl+    -- We only want Givens from this level; see (3a) in+    -- Note [The superclass story] in GHC.Tc.Solver.Dict++getUnsolvedInerts :: TcS Cts    -- All simple constraints+-- Return all the unsolved [Wanted] 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+           , inert_qcis   = qcis+           } <- getInertCans++      ; let unsolved_tv_eqs  = foldTyEqs  (add_if_unsolved CEqCan)    tv_eqs emptyCts+            unsolved_fun_eqs = foldFunEqs (add_if_unsolved CEqCan)    fun_eqs emptyCts+            unsolved_irreds  = foldr      (add_if_unsolved CIrredCan) emptyCts irreds+            unsolved_dicts   = foldDicts  (add_if_unsolved CDictCan)  idicts emptyCts+            unsolved_qcis    = foldr      (add_if_unsolved CQuantCan) emptyCts qcis++      ; traceTcS "getUnsolvedInerts" $+        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs+             , text "fun eqs =" <+> ppr unsolved_fun_eqs+             , text "dicts =" <+> ppr unsolved_dicts+             , text "irreds =" <+> ppr unsolved_irreds ]++      ; return ( unsolved_tv_eqs  `unionBags`+                 unsolved_fun_eqs `unionBags`+                 unsolved_irreds  `unionBags`+                 unsolved_dicts   `unionBags`+                 unsolved_qcis ) }+  where+    add_if_unsolved :: (a -> Ct) -> a -> Cts -> Cts+    add_if_unsolved mk_ct thing cts+      | isWantedCt ct = ct `consCts` cts+      | otherwise     = cts+      where+        ct = mk_ct thing+++getHasGivenEqs :: TcLevel             -- TcLevel of this implication+               -> TcS ( HasGivenEqs   -- are there Given equalities?+                      , InertIrreds ) -- 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 given_insols = filterBag insoluble_given_equality irreds+                      -- Specifically includes ones that originated in some+                      -- outer context but were refined to an insoluble by+                      -- a local equality; so no level-check needed++             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and+             -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet+             has_ge | ge_lvl `sameDepthAs` 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 given_insols]+       ; return (has_ge, given_insols) }+  where+    insoluble_given_equality :: IrredCt -> Bool+    -- Check for unreachability; specifically do not include UserError/Unsatisfiable+    insoluble_given_equality (IrredCt { ir_ev = ev, ir_reason = reason })+       = isInsolubleReason reason && isGiven ev++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 dict_ct -> is { inert_dicts = delDict dict_ct (inert_dicts is) }+      CEqCan    eq_ct  -> delEq    eq_ct is+      CIrredCan ir_ct  -> delIrred ir_ct is+      CQuantCan {}     -> panic "removeInertCt: CQuantCan"+      CNonCanonical {} -> panic "removeInertCt: CNonCanonical"++-- | Looks up a family application in the inerts.+lookupFamAppInert :: (CtFlavourRole -> Bool)  -- can it rewrite the target?+                  -> TyCon -> [Type] -> TcS (Maybe EqCt)+lookupFamAppInert rewrite_pred fam_tc tys+  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getInertSet+       ; return (lookup_inerts inert_funeqs) }+  where+    lookup_inerts inert_funeqs+      = case findFunEq inert_funeqs fam_tc tys of+          Nothing              -> Nothing+          Just (ecl :: [EqCt]) -> find (rewrite_pred . eqCtFlavourRole) ecl++---------------------------+lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction)+lookupFamAppCache fam_tc tys+  = do { IS { inert_famapp_cache = famapp_cache } <- getInertSet+       ; case findFunEq famapp_cache fam_tc tys of+           result@(Just redn) ->+             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)+                                                    , ppr redn ])+                ; return result }+           Nothing -> return Nothing }++extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS ()+-- NB: co :: rhs ~ F tys, to match expectations of rewriter+extendFamAppCache tc xi_args stuff@(Reduction _ ty)+  = do { dflags <- getDynFlags+       ; when (gopt Opt_FamAppCache dflags) $+    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args+                                            , ppr ty ])+       ; updInertSet $ \ 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+  = updInertSet (\inerts@(IS { inert_famapp_cache = famapp_cache }) ->+                   inerts { inert_famapp_cache = filterTcAppMap check famapp_cache })+  where+    check :: Reduction -> Bool+    check redn+      = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn)++{-+************************************************************************+*                                                                      *+*              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.+-}++-- | The mode for the constraint solving monad.+data TcSMode+  = TcSMode -- See Note [TcSMode], where each field is documented+            { tcsmResumable        :: Bool+                   -- ^ Do not restore type-equality cycles+            , tcsmEarlyAbort       :: Bool+                   -- ^ Abort early on insoluble constraints+            , tcsmSkipOverlappable :: Bool+                   -- ^ Do not select an OVERLAPPABLE instance+            , tcsmFullySolveQCIs   :: Bool+                   -- ^ Fully solve quantified constraints+            }++vanillaTcSMode :: TcSMode+vanillaTcSMode = TcSMode { tcsmResumable        = False+                         , tcsmEarlyAbort       = False+                         , tcsmSkipOverlappable = False+                         , tcsmFullySolveQCIs   = False }++instance Outputable TcSMode where+  ppr (TcSMode { tcsmResumable = pm, tcsmEarlyAbort = ea+               , tcsmSkipOverlappable = so, tcsmFullySolveQCIs = fs })+    = text "TcSMode" <> (braces $ cat $ punctuate comma $ catMaybes $+                         [ pp_one pm "Resumable", pp_one ea "EarlyAbort"+                         , pp_one so "SkipOverlappable", pp_one fs "FullySolveQCIs" ])+      -- We get something like TcSMode{EarlyAbort,FullySolveQCIs},+      -- mentioning just the flags that are on+    where+      pp_one True s  = Just (text s)+      pp_one False _ = Nothing++{- Note [TcSMode]+~~~~~~~~~~~~~~~~~+The constraint solver can operate in different modes:++* `tcsmResumable`: Used by the pattern match overlap checker.  The idea is that+  the returned InertSet will later be resumed, so we do not want to restore+  type-equality cycles See also Note [Type equality cycles] in GHC.Tc.Solver.Equality++* `tcsmEarlyAbort`: Abort (fail in the monad) as soon as we come across an+  insoluble constraint. This is used to fail-fast when checking for hole-fits.+  See Note [Speeding up valid hole-fits].++* `tcsmSkipOverlappable`: don't use OVERLAPPABLE instances.  Used by the+  short-cut solver.  See Note [Shortcut solving] in GHC.Tc.Solver.Dict++* `tcsmFullSolveQCIs`: fully solve quantified constraints, or leave them alone.+  Used (only) for SPECIALISE pragmas;+  see (NFS1) in Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig+-}++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, so it+         -- could equally well be a Bool instead of an Int.++      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++      -- | The mode of operation for the constraint solver.+      -- See Note [TcSMode]+      tcs_mode :: TcSMode,++      tcs_worklist :: IORef WorkList+    }++---------------+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }+  deriving (Functor)++instance MonadFix TcS where+  mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env)++-- | 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 MonadIO TcS where+  liftIO act = TcS $ \_env -> liftIO act++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++liftZonkTcS :: ZonkM a -> TcS a+liftZonkTcS = wrapTcS . TcM.liftZonkM++wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a+wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env)++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++panicTcS  :: SDoc -> TcS a+failTcS   :: TcRnMessage -> TcS a+warnTcS, addErrTcS :: TcRnMessage -> TcS ()+failTcS      = wrapTcS . TcM.failWith+warnTcS msg  = wrapTcS (TcM.addDiagnostic msg)+addErrTcS    = wrapTcS . TcM.addErr+panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc++tryEarlyAbortTcS :: TcS ()+-- Abort (fail in the monad) if the mode is TcSEarlyAbort+tryEarlyAbortTcS+  = mkTcS (\env -> when (tcsmEarlyAbort (tcs_mode env)) TcM.failM)++-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'.+ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS ()+ctLocWarnTcS loc msg = wrapTcS $ TcM.setCtLocM loc $ TcM.addDiagnostic msg++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 = wrapTcS . runTcPluginM++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 { logger <- getLogger+       ; when (  logHasDumpFlag logger Opt_D_dump_cs_trace+                  || logHasDumpFlag logger Opt_D_dump_tc_trace)+              ( 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 immediately fail upon encountering an+-- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage+-- site does not need the ev_binds, so we do not return them.+runTcSEarlyAbort :: TcS a -> TcM a+runTcSEarlyAbort tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; runTcSWithEvBinds' mode ev_binds_var tcs }+  where+    mode = vanillaTcSMode { tcsmEarlyAbort = True }++-- | 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' (vanillaTcSMode { tcsmResumable = True })+                             ev_binds_var $+         do { setInertSet inerts+            ; a <- tcs+            ; new_inerts <- getInertSet+            ; return (a, new_inerts) } }++runTcSWithEvBinds :: EvBindsVar+                  -> TcS a+                  -> TcM a+runTcSWithEvBinds = runTcSWithEvBinds' vanillaTcSMode++runTcSWithEvBinds' :: TcSMode+                   -> EvBindsVar+                   -> TcS a+                   -> TcM a+runTcSWithEvBinds' mode ev_binds_var thing_inside+  = do { unified_var <- TcM.newTcRef 0+       ; step_count  <- TcM.newTcRef 0++       -- Make a fresh, empty inert set+       -- Subtle point: see (TGE6) in Note [Tracking Given equalities]+       --               in GHC.Tc.Solver.InertSet+       ; tc_lvl      <- TcM.getTcLevel+       ; inert_var   <- TcM.newTcRef (emptyInertSet tc_lvl)++       ; 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_mode               = mode+                          , tcs_worklist           = wl_var }++             -- Run the computation+       ; res <- unTcS thing_inside env++       ; count <- TcM.readTcRef step_count+       ; when (count > 0) $+         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)++       -- Restore tyvar cycles: see Note [Type equality cycles] in+       --                       GHC.Tc.Solver.Equality+       -- But /not/ when tcsmResumable is set: see Note [TcSMode]+       ; unless (tcsmResumable mode) $+         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 }) = isEqPred (varType b)++    edges :: [ Node EvVar EvBind ]+    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (nestedEvIdsOfTerm 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 })++setTcLevelTcS :: TcLevel -> TcS a -> TcS a+setTcLevelTcS lvl (TcS thing_inside)+ = TcS $ \ env -> TcM.setTcLevel lvl (thing_inside env)++nestImplicTcS :: EvBindsVar+              -> TcLevel -> TcS a+              -> TcS a+nestImplicTcS ev_binds_var inner_tclvl (TcS thing_inside)+  = TcS $ \ env@(TcSEnv { tcs_inerts = old_inert_var }) ->+    do { inerts <- TcM.readTcRef old_inert_var++       -- Initialise the inert_cans from the inert_givens of the parent+       -- so that the child is not polluted with the parent's inert Wanteds+       -- See Note [trySolveImplication] in GHC.Tc.Solver.Solve+       -- All other InertSet fields are inherited+       ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack+                                                            (inert_cycle_breakers inerts)+                                 , inert_cans = (inert_givens inerts)+                                                   { inert_given_eqs = False } }+       ; new_inert_var <- TcM.newTcRef nest_inert+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = env { tcs_ev_binds = ev_binds_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 ev_binds_var+       ; 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 }+                        -- Inherit tcs_ev_binds from caller++       ; res <- thing_inside nest_env++       ; new_inerts <- TcM.readTcRef new_inert_var+       ; TcM.updTcRef inerts_var (`updateInertsWith` new_inerts)++       ; return res }++tryShortCutTcS :: TcS Bool -> TcS Bool+-- Like nestTcS, but+--   (a) be a no-op if the nested computation returns False+--   (b) if (but only if) success, propagate nested bindings to the caller+-- Use only by the short-cut solver;+--   see Note [Shortcut solving] in GHC.Tc.Solver.Dict+tryShortCutTcS (TcS thing_inside)+  = TcS $ \ env@(TcSEnv { tcs_mode = mode+                        , tcs_inerts = inerts_var+                        , tcs_ev_binds = old_ev_binds_var }) ->+    do { -- Initialise a fresh inert set, with no Givens and no Wanteds+         --    (i.e. empty `inert_cans`)+         -- But inherit all the InertSet cache fields; in particular+         --  * the given_eq_lvl, so we don't accidentally unify a+         --    unification variable from outside a GADT match+         --  * the `solved_dicts`; see wrinkle (SCS3) of Note [Shortcut solving]+         --  * the `famapp_cache`; similarly+         old_inerts <- TcM.readTcRef inerts_var+       ; let given_eq_lvl = inert_given_eq_lvl (inert_cans old_inerts)+             new_inerts   = old_inerts { inert_cans = emptyInertCans given_eq_lvl }+       ; new_inert_var <- TcM.newTcRef new_inerts++       ; new_wl_var       <- TcM.newTcRef emptyWorkList+       ; new_ev_binds_var <- TcM.cloneEvBindsVar old_ev_binds_var+       ; let nest_env = env { tcs_mode     = mode { tcsmSkipOverlappable = True }+                            , tcs_ev_binds = new_ev_binds_var+                            , tcs_inerts   = new_inert_var+                            , tcs_worklist = new_wl_var }++       ; TcM.traceTc "tryTcS {" $+         vcat [ text "old_ev_binds:" <+> ppr old_ev_binds_var+              , text "new_ev_binds:" <+> ppr new_ev_binds_var+              , ppr old_inerts ]+       ; solved <- thing_inside nest_env+       ; TcM.traceTc "tryTcS }" (ppr solved)++       ; if not solved+         then return False+         else do {  -- Successfully solved+                   -- Add the new bindings to the existing ones+                 ; TcM.updTcEvBinds old_ev_binds_var new_ev_binds_var++                 -- Update the existing inert set+                 ; new_inerts <- TcM.readTcRef new_inert_var+                 ; TcM.updTcRef inerts_var (`updateInertsWith` new_inerts)++                 ; TcM.traceTc "tryTcS update" (ppr (inert_solved_dicts new_inerts))++                 ; return True } }++updateInertsWith :: InertSet -> InertSet -> InertSet+-- Update the current inert set with bits from a nested solve,+-- that finished with a new inert set+-- In particular, propagate:+--    - solved dictionaires; see Note [Propagate the solved dictionaries]+--    - Safe Haskell failures+updateInertsWith current_inerts+                 (IS { inert_solved_dicts = new_solved+                     , inert_safehask     = new_safehask })+  = current_inerts { inert_solved_dicts = new_solved+                   , inert_safehask     = new_safehask }++{- 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+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++getTcSMode :: TcS TcSMode+getTcSMode = TcS (return . tcs_mode)++setTcSMode :: TcSMode -> TcS a -> TcS a+setTcSMode mode thing_inside+  = TcS (\env -> unTcS thing_inside (env { tcs_mode = mode }))++getUnifiedRef :: TcS (IORef Int)+getUnifiedRef = TcS (return . tcs_unified)++-- Getter of inerts and worklist+getInertSetRef :: TcS (IORef InertSet)+getInertSetRef = TcS (return . tcs_inerts)++getInertSet :: TcS InertSet+getInertSet = getInertSetRef >>= readTcRef++setInertSet :: InertSet -> TcS ()+setInertSet is = do { r <- getInertSetRef; writeTcRef r is }+++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 [TcCoercion]+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.liftZonkM $ TcM.writeMetaTyVar tv ty+       ; TcM.updTcRef (tcs_unified env) (+1) }++reportUnifications :: TcS a -> TcS (Int, a)+-- Record how many unifications are done by thing_inside+-- We could return a Bool instead of an Int;+-- all that matters is whether it is no-zero+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 (DefaultEnv, 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++setSrcSpan :: RealSrcSpan -> TcS a -> TcS a+setSrcSpan ss = wrap2TcS (TcM.setSrcSpan (RealSrcSpan ss mempty))++tcLookupClass :: Name -> TcS Class+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c++tcLookupId :: Name -> TcS Id+tcLookupId n = wrapTcS $ TcM.tcLookupId n++tcLookupTyCon :: Name -> TcS TyCon+tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyCon n++-- Any use of this function is a bit suspect, because it violates the+-- pure veneer of TcS. But it's just about warnings around unused imports+-- and local constructors (GHC will issue fewer warnings than it otherwise+-- might), so it's not worth losing sleep over.+recordUsedGREs :: Bag GlobalRdrElt -> TcS ()+recordUsedGREs gres+  = do { wrapTcS $ TcM.addUsedGREs NoDeprecationWarnings gre_list+         -- If a newtype constructor was imported, don't warn about not+         -- importing it...+       ; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list }+         -- ...and similarly, if a newtype constructor was defined in the same+         -- module, don't warn about it being unused.+         -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.++  where+    gre_list = bagToList gres++-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++checkWellLevelledDFun :: 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++checkWellLevelledDFun loc what pred+  = do+      mbind_lvl <- checkWellLevelledInstanceWhat what+      case mbind_lvl of+        Just (bind_lvls, is_local) ->+          wrapTcS $ TcM.setCtLocM loc $ do+              { use_lvl <- thLevelIndex <$> TcM.getThLevel+              ; dflags <- getDynFlags+              ; checkCrossLevelClsInst dflags (LevelCheckInstance what pred) bind_lvls use_lvl is_local  }+        -- If no level information is returned for an InstanceWhat, then it's safe to use+        -- at any level.+        Nothing -> return ()+++-- TODO: Unify this with checkCrossLevelLifting function+checkCrossLevelClsInst :: DynFlags -> LevelCheckReason+                       -> Set.Set ThLevelIndex -> ThLevelIndex+                       -> Bool -> TcM ()+checkCrossLevelClsInst dflags reason bind_lvls use_lvl_idx is_local+  -- If the Id is imported, then allow with ImplicitStagePersistence+  | not is_local+  , xopt LangExt.ImplicitStagePersistence dflags+  = return ()+  -- NB: Do this check after the ImplicitStagePersistence check, because+  -- it will do some computation to work out the levels of instances.+  | use_lvl_idx `Set.member` bind_lvls = return ()+  -- With ImplicitStagePersistence, using later than bound is fine+  | xopt LangExt.ImplicitStagePersistence dflags+  , any (use_lvl_idx >=) bind_lvls  = return ()+  | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx Nothing ErrorWithoutFlag)++++-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)+-- See Note [Well-levelled instance evidence]+checkWellLevelledInstanceWhat :: HasCallStack => InstanceWhat -> TcS (Maybe (Set.Set ThLevelIndex, Bool))+checkWellLevelledInstanceWhat what+  | TopLevInstance { iw_dfun_id = dfun_id } <- what+    = Just <$> checkNameVisibleLevels (idName dfun_id)+  | BuiltinTypeableInstance tc <- what+    -- The typeable instance is always defined in the same module as the TyCon.+    = Just <$> checkNameVisibleLevels (tyConName tc)+  | otherwise = return Nothing++-- | Check the levels at which the given name is visible, including a boolean+-- indicating if the name is local or not.+checkNameVisibleLevels :: Name -> TcS (Set.Set ThLevelIndex, Bool)+checkNameVisibleLevels name = do+  cur_mod <- extractModule <$> getGblEnv+  if nameIsLocalOrFrom cur_mod name+    then return (Set.singleton topLevelIndex, True)+    else do+      lvls <- checkModuleVisibleLevels (nameModule name)+      return (lvls, False)++{- Note [Using the module graph to compute TH level visiblities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typechecking a module M, in order to implement GHC proposal #682+(see Note [Explicit Level Imports] in GHC.Tc.Gen.Head), we need to be able to+compute the Template Haskell levels that typeclass instances are visible at in M.++To do this, we use the "level 0 imports" module graph, which we query via+GHC.Unit.Module.Graph.mgQueryZero. For example, if we want all modules that are+visible at level -1 from M, we do the following:++  1. start with all the direct of M imports at level -1, i.e. the "splice imports"+  2. then look at all modules that are reachable from these using only level 0+     normal imports, using 'mgQueryZero'.++This works precisely because, as specified in the proposal, with -XNoImplicitStagePersistence,+modules only export items at level 0. In particular, instances are only exported+at level 0.++See the SI36 test for an illustration.+-}++-- | Check which TH levels a module is visable at+--+-- Used to check visibility of instances (do not use this for normal identifiers).+checkModuleVisibleLevels :: Module -> TcS (Set.Set ThLevelIndex)+checkModuleVisibleLevels check_mod = do+  cur_mod <- extractModule <$> getGblEnv+  hsc_env <- getTopEnv++  -- 0. The keys for the scope of the current module.+  let mkKey s m = (ModuleScope (moduleToMnk m NotBoot) s)+      cur_mod_scope_key s = mkKey s cur_mod++  -- 1. is_visible checks that a specific key is visible from the given level in the+  -- current module.+  let is_visible :: ImportLevel -> ZeroScopeKey -> Bool+      is_visible s k = mgQueryZero (hsc_mod_graph hsc_env) (cur_mod_scope_key s) k++  -- 2. The key we are looking for, either the module itself in the home package or the+  -- module unit id of the module we are checking.+  let instance_key = if moduleUnitId check_mod `Set.member` hsc_all_home_unit_ids hsc_env+                       then mkKey NormalLevel check_mod+                       else UnitScope (moduleUnitId check_mod)++  -- 3. For each level, check if the key is visible from that level.+  let lvls = [ thLevelIndexFromImportLevel lvl | lvl <- allImportLevels, is_visible lvl instance_key]+  return $ Set.fromList lvls++{-+Note [Well-levelled instance evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Evidence for instances must obey the same level restrictions as normal bindings.+In particular, it is forbidden to use an instance in a top-level splice in the+module which the instance is defined. This is because the evidence is bound at+the top-level and top-level definitions are forbidden from being using in top-level splices in+the same module.++For example, suppose you have a function..  foo :: Show a => Code Q a -> Code Q ()+then the following program is disallowed,++```+data T a = T a deriving (Show)++main :: IO ()+main =+  let x = $$(foo [|| T () ||])+  in return ()+```++because the `foo` function (used in a top-level splice) requires `Show T` evidence,+which is defined at the top-level and therefore fails with an error that we have violated+the stage restriction.++```+Main.hs:12:14: error:+    • GHC stage restriction:+        instance for ‘Show+                        (T ())’ is used in a top-level splice, quasi-quote, or annotation,+        and must be imported, not defined locally+    • In the expression: foo [|| T () ||]+      In the Template Haskell splice $$(foo [|| T () ||])+      In the expression: $$(foo [|| T () ||])+   |+12 |   let x = $$(foo [|| T () ||])+   |+```++Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on+`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT`+is well levelled.  It's easy to know the level of `$tcT`: for imported TyCons it+will be the level of the imported TyCon Name, and for local TyCons it will be `toplevel`.++Therefore the `InstanceWhat` type had to be extended with+a special case for `Typeable`, which recorded the TyCon the evidence was for and+could them be used to check that we were not attempting to evidence in a level incorrect+manner.++-}++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)++isUnfilledMetaTyVar :: TcTyVar -> TcS Bool+isUnfilledMetaTyVar tv = wrapTcS $ TcM.isUnfilledMetaTyVar tv++zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet+zonkTyCoVarsAndFV tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFV tvs)++zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]+zonkTyCoVarsAndFVList tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFVList tvs)++zonkCo :: Coercion -> TcS Coercion+zonkCo = wrapTcS . fmap TcM.liftZonkM TcM.zonkCo++zonkTcType :: TcType -> TcS TcType+zonkTcType ty = liftZonkTcS (TcM.zonkTcType ty)++zonkTcTypes :: [TcType] -> TcS [TcType]+zonkTcTypes tys = liftZonkTcS (TcM.zonkTcTypes tys)++zonkTcTyVar :: TcTyVar -> TcS TcType+zonkTcTyVar tv = liftZonkTcS (TcM.zonkTcTyVar tv)++zonkSimples :: Cts -> TcS Cts+zonkSimples cts = liftZonkTcS (TcM.zonkSimples cts)++zonkWC :: WantedConstraints -> TcS WantedConstraints+zonkWC wc = liftZonkTcS (TcM.zonkWC wc)++zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar+zonkTyCoVarKind tv = liftZonkTcS (TcM.zonkTyCoVarKind tv)++----------------------------+pprKicked :: Int -> SDoc+pprKicked 0 = empty+pprKicked n = parens (int n <+> text "kicked out")+++{- *********************************************************************+*                                                                      *+*              The work list+*                                                                      *+********************************************************************* -}+++getTcSWorkListRef :: TcS (IORef WorkList)+getTcSWorkListRef = TcS (return . tcs_worklist)++getWorkList :: TcS WorkList+getWorkList = do { wl_var <- getTcSWorkListRef+                 ; readTcRef wl_var }++updWorkListTcS :: (WorkList -> WorkList) -> TcS ()+updWorkListTcS f+  = do { wl_var <- getTcSWorkListRef+       ; updTcRef wl_var f }++emitWorkNC :: [CtEvidence] -> TcS ()+emitWorkNC evs+  | null evs+  = return ()+  | otherwise+  = emitWork (listToBag (map mkNonCanonical evs))++emitWork :: Cts -> TcS ()+emitWork cts+  | isEmptyBag cts    -- Avoid printing, among other work+  = return ()+  | otherwise+  = do { traceTcS "Emitting fresh work" (pprBag cts)+       ; updWorkListTcS (extendWorkListCts cts) }++selectNextWorkItem :: TcS (Maybe Ct)+-- Pick which work item to do next+-- See Note [Prioritise equalities]+--+-- Postcondition: if the returned item is a Wanted equality,+--                then its rewriter set is fully zonked.+--+-- Suppose a constraint c1 is rewritten by another, c2.  When c2+-- gets solved, c1 has no rewriters, and can be prioritised; see+-- Note [Prioritise Wanteds with empty RewriterSet] in+-- GHC.Tc.Types.Constraint wrinkle (PER1)++-- ToDo: if wl_rw_eqs is long, we'll re-zonk it each time we pick+--       a new item from wl_rest.  Bad.+selectNextWorkItem+  = do { wl_var <- getTcSWorkListRef+       ; wl     <- readTcRef wl_var++       ; case wl of { WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X+                         , wl_rw_eqs = rw_eqs, wl_rest = rest }+           | ct:cts <- eqs_N  -> pick_me ct (wl { wl_eqs_N  = cts })+           | ct:cts <- eqs_X  -> pick_me ct (wl { wl_eqs_X  = cts })+           | otherwise        -> try_rws [] rw_eqs+           where+             pick_me :: Ct -> WorkList -> TcS (Maybe Ct)+             pick_me ct new_wl+               = do { writeTcRef wl_var new_wl+                    ; return (Just ct) }+                 -- NB: no need for checkReductionDepth (ctLoc ct) (ctPred ct)+                 -- This is done by GHC.Tc.Solver.Dict.chooseInstance++             -- try_rws looks through rw_eqs to find one that has an empty+             -- rewriter set, after zonking.  If none such, call try_rest.+             try_rws acc (ct:cts)+                = do { ct' <- liftZonkTcS (TcM.zonkCtRewriterSet ct)+                     ; if ctHasNoRewriters ct'+                       then pick_me ct' (wl { wl_rw_eqs = cts ++ acc })+                       else try_rws (ct':acc) cts }+             try_rws acc [] = try_rest acc++             try_rest zonked_rws+               | ct:cts <- rest       = pick_me ct (wl { wl_rw_eqs = zonked_rws, wl_rest = cts })+               | ct:cts <- zonked_rws = pick_me ct (wl { wl_rw_eqs = cts })+               | otherwise            = return Nothing+     } }+++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+++{- *********************************************************************+*                                                                      *+*              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 is 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 [W] 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)++instFlexiX :: Subst -> [TKVar] -> TcS Subst+instFlexiX subst tvs = wrapTcS (instFlexiXTcM subst tvs)++instFlexiXTcM :: Subst -> [TKVar] -> TcM Subst+-- Makes fresh tyvar, extends the substitution, and the in-scope set+-- Takes account of the case [k::Type, a::k, ...],+-- where we must substitute for k in a's kind+instFlexiXTcM subst []+  = return subst+instFlexiXTcM subst (tv:tvs)+  = do { uniq <- TcM.newUnique+       ; details <- TcM.newMetaDetails TauTv+       ; let name   = setNameUnique (tyVarName tv) uniq+             kind   = substTyUnchecked subst (tyVarKind tv)+             tv'    = mkTcTyVar name kind details+             subst' = extendTvSubstWithClone subst tv tv'+       ; instFlexiXTcM subst' tvs  }++matchGlobalInst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS TcM.ClsInstResult+matchGlobalInst dflags cls tys loc+  = do { mode <- getTcSMode+       ; let skip_overlappable = tcsmSkipOverlappable mode+       ; wrapTcS $ TcM.matchGlobalInst dflags skip_overlappable cls tys (Just loc) }++tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar])+tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs++-- Creating and setting evidence variables and CtFlavors+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data MaybeNew = Fresh WantedCtEvidence | Cached EvExpr++isFresh :: MaybeNew -> Bool+isFresh (Fresh {})  = True+isFresh (Cached {}) = False++freshGoals :: [MaybeNew] -> [WantedCtEvidence]+freshGoals mns = [ ctev | Fresh ctev <- mns ]++getEvExpr :: MaybeNew -> EvExpr+getEvExpr (Fresh ctev) = ctEvExpr (CtWanted 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+addUsedCoercion :: TcCoercion -> TcS ()+addUsedCoercion co+  = do { ev_binds_var <- getTcEvBindsVar+       ; wrapTcS (TcM.updTcRef (ebv_tcvs ev_binds_var) (co :)) }++-- | Equalities only+setWantedEq :: HasDebugCallStack => TcEvDest -> TcCoercion -> TcS ()+setWantedEq (HoleDest hole) co+  = do { addUsedCoercion co+       ; fillCoercionHole hole co }+setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)++-- | Good for both equalities and non-equalities+setWantedEvTerm :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS ()+setWantedEvTerm (HoleDest hole) _canonical tm+  | Just co <- evTermCoercion_maybe tm+  = do { addUsedCoercion co+       ; fillCoercionHole hole co }+  | otherwise+  = -- See Note [Yukky eq_sel for a HoleDest]+    do { let co_var = coHoleCoVar hole+       ; setEvBind (mkWantedEvBind co_var EvCanonical tm)+       ; fillCoercionHole hole (mkCoVarCo co_var) }++setWantedEvTerm (EvVarDest ev_id) canonical tm+  = setEvBind (mkWantedEvBind ev_id canonical 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 }++setEvBindIfWanted :: CtEvidence -> CanonicalEvidence -> EvTerm -> TcS ()+setEvBindIfWanted ev canonical tm+  = case ev of+      CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest canonical 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 GivenCtEvidence+-- 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 $ GivenCt { 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 }++emitNewGivens :: CtLoc -> [(Role,TcCoercion)] -> TcS ()+emitNewGivens loc pts+  = do { traceTcS "emitNewGivens" (ppr pts)+       ; gs <- mapM (newGivenEvVar loc) $+                [ (mkEqPredRole role ty1 ty2, evCoercion co)+                | (role, co) <- pts+                , let Pair ty1 ty2 = coercionKind co+                , not (ty1 `tcEqType` ty2) ] -- Kill reflexive Givens at birth+       ; emitWorkNC (map CtGiven gs) }++emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion+-- | Emit a new Wanted equality into the work-list+emitNewWantedEq loc rewriters role ty1 ty2+  = do { (wtd, co) <- newWantedEq loc rewriters role ty1 ty2+       ; updWorkListTcS (extendWorkListEq rewriters (mkNonCanonical $ CtWanted wtd))+       ; return co }++-- | Create a new Wanted constraint holding a coercion hole+-- for an equality between the two types at the given 'Role'.+newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType+            -> TcS (WantedCtEvidence, Coercion)+newWantedEq loc rewriters role ty1 ty2+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty+       ; let wtd = WantedCt { ctev_pred      = pty+                            , ctev_dest      = HoleDest hole+                            , ctev_loc       = loc+                            , ctev_rewriters = rewriters }+       ; return (wtd, mkHoleCo hole) }+  where+    pty = mkEqPredRole role ty1 ty2++-- | Create a new Wanted constraint holding an evidence variable.+--+-- Don't use this for equality constraints: use 'newWantedEq' instead.+newWantedEvVarNC :: CtLoc -> RewriterSet+                 -> TcPredType -> TcS WantedCtEvidence+-- Don't look up in the solved/inerts; we know it's not there+newWantedEvVarNC loc rewriters pty+  = assertPpr (not (isEqPred pty)) (ppr pty) $+    do { new_ev <- newEvVar pty+       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$+                                         pprCtLoc loc)+       ; return $ WantedCt { ctev_pred      = pty+                           , ctev_dest      = EvVarDest new_ev+                           , ctev_loc       = loc+                           , ctev_rewriters = rewriters }+       }++-- | `newWantedEvVar` makes up a fresh evidence variable for the given predicate.+-- For ClassPred, check if this exact predicate type is in the solved dicts+--      But do /not/ look in the inert_cans, because doing so bypasses all+--      all the careful tests in tryInertDicts, leading to+--      #20666 (prohibitedSuperClassSolve) and #26117 (short-cut solve)+-- We do no such caching forIPs, holes, or errors; so for anything+-- except ClassPred, this is the same as newWantedEvVarNC+--+-- Don't use this for equality constraints: this function is only for+-- constraints with 'EvVarDest'.+newWantedEvVar :: CtLoc -> RewriterSet+               -> TcPredType -> TcS MaybeNew+newWantedEvVar loc rewriters pty+  = case classifyPredType pty of+      EqPred {} -> pprPanic "newWantedEvVar: HoleDestPred" (ppr pty)+      ClassPred cls tys+        -> do { inerts <- getInertSet+              ; case lookupSolvedDict inerts cls tys of+                 Just ev -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ev+                               ; return $ Cached (ctEvExpr ev) }+                 Nothing -> do { ev <- newWantedEvVarNC loc rewriters pty+                               ; return (Fresh ev) } }+      _other -> do { ev <- newWantedEvVarNC loc rewriters pty+                   ; return (Fresh ev) }++-- | Create a new Wanted constraint, potentially looking up+-- non-equality constraints in the cache instead of creating+-- a new one from scratch.+--+-- Deals with both equality and non-equality constraints.+newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew+newWanted loc rewriters pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2+  | otherwise+  = newWantedEvVar loc rewriters pty++-- | Create a new Wanted constraint.+--+-- Deals with both equality and non-equality constraints.+--+-- Does not attempt to re-use non-equality constraints that already+-- exist in the inert set.+newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS WantedCtEvidence+newWantedNC loc rewriters pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = fst <$> newWantedEq loc rewriters role ty1 ty2+  | otherwise+  = newWantedEvVarNC loc rewriters pty++-- | 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 (reductionDepth dflags) (ctLocDepth loc)) $+         wrapErrTcS $ solverDepthError loc ty }++matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN)+matchFam tycon args = wrapTcS $ matchFamTcM tycon args++matchFamTcM :: TyCon -> [Type] -> TcM (Maybe ReductionN)+-- 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 (Reduction co ty))+      = hang (text "Match succeeded:")+          2 (vcat [ text "Rewrites to:" <+> ppr ty+                  , text "Coercion:" <+> ppr co ])++solverDepthError :: CtLoc -> TcType -> TcM a+solverDepthError loc ty+  = TcM.setCtLocM loc $+    do { (ty, env0) <- TcM.liftZonkM $+           do { ty   <- TcM.zonkTcType ty+              ; env0 <- TcM.tcInitTidyEnv+              ; return (ty, env0) }+       ; let (tidy_env, tidy_ty)  = tidyOpenTypeX env0 ty+             msg = TcRnSolverDepthError tidy_ty depth+       ; TcM.failWithTcM (tidy_env, msg) }+  where+    depth = ctLocDepth loc++{-+************************************************************************+*                                                                      *+              Emitting equalities arising from fundeps+*                                                                      *+************************************************************************+-}++emitFunDepWanteds :: CtEvidence  -- The work item+                  -> [FunDepEqn (CtLoc, RewriterSet)]+                  -> TcS Bool  -- True <=> some unification happened++emitFunDepWanteds _ [] = return False -- common case noop+-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict++emitFunDepWanteds ev fd_eqns+  = unifyFunDeps ev Nominal do_fundeps+  where+    do_fundeps :: UnifyEnv -> TcM ()+    do_fundeps env = mapM_ (do_one env) fd_eqns++    do_one :: UnifyEnv -> FunDepEqn (CtLoc, RewriterSet) -> TcM ()+    do_one uenv (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) })+      = do { eqs' <- instantiate_eqs tvs (reverse eqs)+                     -- (reverse eqs): See Note [Reverse order of fundep equations]+           ; uPairsTcM env_one eqs' }+      where+        env_one = uenv { u_rewriters = u_rewriters uenv S.<> rewriters+                       , u_loc       = loc }++    instantiate_eqs :: [TyVar] -> [TypeEqn] -> TcM [TypeEqn]+    instantiate_eqs tvs eqs+      | null tvs+      = return eqs+      | otherwise+      = do { TcM.traceTc "emitFunDepWanteds 2" (ppr tvs $$ ppr eqs)+           ; subst <- instFlexiXTcM emptySubst tvs  -- Takes account of kind substitution+           ; return [ Pair (substTyUnchecked subst' ty1) ty2+                           -- ty2 does not mention fd_qtvs, so no need to subst it.+                           -- See GHC.Tc.Instance.Fundeps Note [Improving against instances]+                           --     Wrinkle (1)+                    | Pair ty1 ty2 <- eqs+                    , let subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1) ]+                          -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result+                          -- of matching with the [W] constraint. So we add its free+                          -- vars to InScopeSet, to satisfy substTy's invariants, even+                          -- though ty1 will never (currently) be a poytype, so this+                          -- InScopeSet will never be looked at.+           }++{-+************************************************************************+*                                                                      *+              Unification+*                                                                      *+************************************************************************++Note [wrapUnifierTcS]+~~~~~~~~~~~~~~~~~~~+When decomposing equalities we often create new wanted constraints for+(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.++Rather than making an equality test (which traverses the structure of the type,+perhaps fruitlessly), we call uType (via wrapUnifierTcS) to traverse the common+structure, and bales out when it finds a difference by creating a new deferred+Wanted constraint.  But where it succeeds in finding common structure, it just+builds a coercion to reflect it.++This is all much faster than creating a new constraint, putting it in the+work list, picking it out, canonicalising it, etc etc.++Note [unifyFunDeps]+~~~~~~~~~~~~~~~~~~~+The Bool returned by `unifyFunDeps` is True if we have unified a variable+that occurs in the constraint we are trying to solve; it is not in the+inert set so `wrapUnifierTcS` won't kick it out.  Instead we want to send it+back to the start of the pipeline.  Hence the Bool.++It's vital that we don't return (not (null unified)) because the fundeps+may create fresh variables; unifying them (alone) should not make us send+the constraint back to the start, or we'll get an infinite loop.  See+Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict+and Note [Improvement orientation] in GHC.Tc.Solver.Equality.+-}++uPairsTcM :: UnifyEnv -> [TypeEqn] -> TcM ()+uPairsTcM uenv eqns = mapM_ (\(Pair ty1 ty2) -> uType uenv ty1 ty2) eqns++unifyFunDeps :: CtEvidence -> Role+             -> (UnifyEnv -> TcM ())+             -> TcS Bool+unifyFunDeps ev role do_unifications+  = do { (_, _, unified) <- wrapUnifierTcS ev role do_unifications+       ; return (any (`elemVarSet` fvs) unified) }+         -- See Note [unifyFunDeps]+  where+    fvs = tyCoVarsOfType (ctEvPred ev)++unifyForAllBody :: CtEvidence -> Role -> (UnifyEnv -> TcM a)+                -> TcS (a, Cts)+-- We /return/ the equality constraints we generate,+-- rather than emitting them into the monad.+-- See See (SF5) in Note [Solving forall equalities] in GHC.Tc.Solver.Equality+unifyForAllBody ev role unify_body+  = do { (res, cts, unified) <- wrapUnifierX ev role unify_body++       -- Kick out any inert constraint that we have unified+       ; _ <- kickOutAfterUnification unified++       ; return (res, cts) }++wrapUnifierTcS :: CtEvidence -> Role+               -> (UnifyEnv -> TcM a)  -- Some calls to uType+               -> TcS (a, Bag Ct, [TcTyVar])+-- Invokes the do_unifications argument, with a suitable UnifyEnv.+-- Emit deferred equalities and kick-out from the inert set as a+-- result of any unifications.+-- Very good short-cut when the two types are equal, or nearly so+-- See Note [wrapUnifierTcS]+--+-- The [TcTyVar] is the list of unification variables that were+-- unified the process; the (Bag Ct) are the deferred constraints.++wrapUnifierTcS ev role do_unifications+  = do { (res, cts, unified) <- wrapUnifierX ev role do_unifications++       -- Emit the deferred constraints+       -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality+       --+       -- All the constraints in `cts` share the same rewriter set so,+       -- rather than looking at it one by one, we pass it to+       -- extendWorkListChildEqs; just a small optimisation.+       ; unless (isEmptyBag cts) $+         updWorkListTcS (extendWorkListChildEqs ev cts)++       -- And kick out any inert constraint that we have unified+       ; _ <- kickOutAfterUnification unified++       ; return (res, cts, unified) }++wrapUnifierX :: CtEvidence -> Role+             -> (UnifyEnv -> TcM a)  -- Some calls to uType+             -> TcS (a, Bag Ct, [TcTyVar])+wrapUnifierX ev role do_unifications+  = do { unif_count_ref <- getUnifiedRef+       ; wrapTcS $+         do { defer_ref   <- TcM.newTcRef emptyBag+            ; unified_ref <- TcM.newTcRef []+            ; let env = UE { u_role      = role+                           , u_rewriters = ctEvRewriters ev+                           , u_loc       = ctEvLoc ev+                           , u_defer     = defer_ref+                           , u_unified   = Just unified_ref}+              -- u_rewriters: the rewriter set and location from+              -- the parent constraint `ev` are inherited in any+              -- new constraints spat out by the unifier++            ; res <- do_unifications env++            ; cts     <- TcM.readTcRef defer_ref+            ; unified <- TcM.readTcRef unified_ref++            -- Don't forget to update the count of variables+            -- unified, lest we forget to iterate (#24146)+            ; unless (null unified) $+              TcM.updTcRef unif_count_ref (+ (length unified))++            ; return (res, cts, unified) } }+++{-+************************************************************************+*                                                                      *+              Breaking type variable cycles+*                                                                      *+************************************************************************+-}++checkTypeEq :: CtEvidence -> EqRel -> CanEqLHS -> TcType+            -> TcS (PuResult () Reduction)+-- Used for general CanEqLHSs, ones that do+-- not have a touchable type variable on the LHS (i.e. not unifying)+checkTypeEq ev eq_rel lhs rhs =+  case ev of+    CtGiven {} ->+      do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs+                                          , text "rhs:" <+> ppr rhs ])+         ; check_result <- wrapTcS (checkTyEqRhs given_flags rhs)+         ; traceTcS "checkTypeEq }" (ppr check_result)+         ; case check_result of+              PuFail reason -> return (PuFail reason)+              PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs+                                  ; emitWork new_givens+                                  ; updInertSet (addCycleBreakerBindings prs)+                                  ; return (pure redn) } }+    CtWanted {} ->+      do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs)+         ; case check_result of+              PuFail reason -> return (PuFail reason)+              PuOK cts redn -> do { emitWork cts+                                  ; return (pure redn) } }+  where+    wanted_flags :: TyEqFlags TcM Ct+    wanted_flags = notUnifying_TEFTask occ_prob lhs+                   -- checkTypeEq deals only with the non-unifying case++    given_flags :: TyEqFlags TcM (TcTyVar, TcType)+    given_flags = wanted_flags { tef_fam_app = mkTEFA_Break ev eq_rel BreakGiven }+        -- TEFA_Break used for: [G] a ~ Maybe (F a)+        --                   or [W] F a ~ Maybe (F a)++    -- occ_prob: see Note [Occurs check and representational equality]+    occ_prob = case eq_rel of+                 NomEq  -> cteInsolubleOccurs+                 ReprEq -> cteSolubleOccurs++    ---------------------------+    mk_new_given :: (TcTyVar, TcType) -> TcS Ct+    mk_new_given (new_tv, fam_app)+      = mkNonCanonical . CtGiven <$> newGivenEvVar cb_loc (given_pred, given_term)+      where+        new_ty     = mkTyVarTy new_tv+        given_pred = mkNomEqPred fam_app new_ty+        given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note++    -- See Detail (7) of the Note+    cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin++-------------------------+-- | Fill in CycleBreakerTvs with the variables they stand for.+-- See Note [Type equality cycles] in GHC.Tc.Solver.Equality+restoreTyVarCycles :: InertSet -> TcM ()+restoreTyVarCycles is+  = TcM.liftZonkM+  $ forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar+{-# SPECIALISE forAllCycleBreakerBindings_ ::+      CycleBreakerVarStack -> (TcTyVar -> TcType -> ZonkM ()) -> ZonkM () #-}+++{- Note [Occurs check and representational equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(a ~R# b a) is soluble if b later turns out to be Identity+So we treat this as a "soluble occurs check".  Note [Don't cycle-break Wanteds when not unifying] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Solver/Rewrite.hs view
@@ -150,16 +150,19 @@       { let !env' = env { re_loc = bumpCtLocDepth (re_loc env) }       ; thing_inside env' } --- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint--- Precondition: the CtEvidence is a CtWanted of an equality recordRewriter :: CtEvidence -> RewriteM ()-recordRewriter (CtWanted { ctev_dest = HoleDest hole })-  = RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriter` hole)-recordRewriter other = pprPanic "recordRewriter" (ppr other)+-- Record that we have rewritten the target with this (equality) evidence+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint+-- Precondition: the CtEvidence is for an equality constraint+recordRewriter (CtGiven {})+  = return ()+recordRewriter (CtWanted (WantedCt { ctev_dest = dest }))+  = case dest of+      HoleDest hole -> RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriter` hole)+      other         -> pprPanic "recordRewriter: non-equality constraint" (ppr other) -{--Note [Rewriter EqRels]-~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Rewriter EqRels]+~~~~~~~~~~~~~~~~~~~~~~~~~ When rewriting, we need to know which equality relation -- nominal or representational -- we should be respecting.  This is controlled by the `re_eq_rel` field of RewriteEnv.@@ -220,7 +223,7 @@ -- | See Note [Rewriting]. -- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty -- where r is the role in @ev@.--- rewriters is the set of coercion holes that have been used to rewrite+-- `rewriters` is the set of coercion holes that have been used to rewrite -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewrite :: CtEvidence -> TcType         -> TcS (Reduction, RewriterSet)@@ -848,16 +851,18 @@           -- STEP 3: try the inerts        ; flavour <- getFlavour-       ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis-       ; case result2 of-         { Just (redn, (inert_flavour, inert_eq_rel))+       ; mb_eq <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis+       ; case mb_eq of+         { Just (EqCt { eq_ev = inert_ev, eq_rhs = inert_rhs, eq_eq_rel = inert_eq_rel })              -> do { traceRewriteM "rewrite family application with inert"                                 (ppr tc <+> ppr xis $$ ppr redn)-                   ; finish (inert_flavour == Given) (homogenise downgraded_redn) }-               -- this will sometimes duplicate an inert in the cache,+                   ; recordRewriter inert_ev+                   ; finish (isGiven inert_ev) (homogenise downgraded_redn) }+               -- This will sometimes duplicate an inert in the cache,                -- but avoiding doing so had no impact on performance, and                -- it seems easier not to weed out that special case              where+               redn            = mkReduction (ctEvCoercion inert_ev) inert_rhs                inert_role      = eqRelRole inert_eq_rel                role            = eqRelRole eq_rel                downgraded_redn = downgradeRedn role inert_role redn@@ -1021,12 +1026,11 @@              | Just ct <- find can_rewrite equal_ct_list              , EqCt { eq_ev = ctev, eq_lhs = TyVarLHS tv                     , eq_rhs = rhs_ty, eq_eq_rel = ct_eq_rel } <- ct-             -> do { let wrw = isWanted ctev-                   ; traceRewriteM "Following inert tyvar" $+             -> do { traceRewriteM "Following inert tyvar" $                         vcat [ ppr tv <+> equals <+> ppr rhs_ty-                             , ppr ctev-                             , text "wanted_rewrite_wanted:" <+> ppr wrw ]-                   ; when wrw $ recordRewriter ctev+                             , ppr ctev ]+                   ; recordRewriter ctev+                         -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint                     ; let rewriting_co1 = ctEvCoercion ctev                          rewriting_co  = case (ct_eq_rel, eq_rel) of
compiler/GHC/Tc/Solver/Solve.hs view
@@ -1,722 +1,1837 @@-{-# LANGUAGE RecursiveDo #-}--module GHC.Tc.Solver.Solve (-     solveSimpleGivens,   -- Solves [Ct]-     solveSimpleWanteds   -- Solves Cts-  ) where--import GHC.Prelude--import GHC.Tc.Solver.Dict-import GHC.Tc.Solver.Equality( solveEquality )-import GHC.Tc.Solver.Irred( solveIrred )-import GHC.Tc.Solver.Rewrite( rewrite )-import GHC.Tc.Errors.Types-import GHC.Tc.Utils.TcType-import GHC.Tc.Types.Evidence-import GHC.Tc.Types.CtLoc( ctLocEnv, ctLocOrigin, setCtLocOrigin )-import GHC.Tc.Types-import GHC.Tc.Types.Origin-import GHC.Tc.Types.Constraint-import GHC.Tc.Solver.InertSet-import GHC.Tc.Solver.Monad--import GHC.Core.Predicate-import GHC.Core.Reduction-import GHC.Core.Coercion-import GHC.Core.Class( classHasSCs )--import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Basic ( IntWithInf, intGtLimit )--import GHC.Data.Bag--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Misc--import GHC.Driver.Session--import Data.List( deleteFirstsBy )--import Control.Monad-import Data.Semigroup as S-import Data.Void( Void )--{--**********************************************************************-*                                                                    *-*                      Main Solver                                   *-*                                                                    *-**********************************************************************--Note [Basic Simplifier Plan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-1. Pick an element from the WorkList if there exists one with depth-   less than our context-stack depth.--2. Run it down the 'stage' pipeline. Stages are:-      - canonicalization-      - inert reactions-      - spontaneous reactions-      - top-level interactions-   Each stage returns a StopOrContinue and may have sideeffected-   the inerts or worklist.--   The threading of the stages is as follows:-      - If (Stop) is returned by a stage then we start again from Step 1.-      - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to-        the next stage in the pipeline.-4. If the element has survived (i.e. ContinueWith x) the last stage-   then we add it in the inerts and jump back to Step 1.--If in Step 1 no such element exists, we have exceeded our context-stack-depth and will simply fail.--}--solveSimpleGivens :: [Ct] -> TcS ()-solveSimpleGivens givens-  | null givens  -- Shortcut for common case-  = return ()-  | otherwise-  = do { traceTcS "solveSimpleGivens {" (ppr givens)-       ; go givens-       ; traceTcS "End solveSimpleGivens }" empty }-  where-    go givens = do { solveSimples (listToBag givens)-                   ; new_givens <- runTcPluginsGiven-                   ; when (notNull new_givens) $-                     go new_givens }--solveSimpleWanteds :: Cts -> TcS WantedConstraints--- The result is not necessarily zonked-solveSimpleWanteds simples-  = do { traceTcS "solveSimpleWanteds {" (ppr simples)-       ; dflags <- getDynFlags-       ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples })-       ; traceTcS "solveSimpleWanteds end }" $-             vcat [ text "iterations =" <+> ppr n-                  , text "residual =" <+> ppr wc ]-       ; return wc }-  where-    go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)-    -- See Note [The solveSimpleWanteds loop]-    go n limit wc-      | n `intGtLimit` limit-      = failTcS $ TcRnSimplifierTooManyIterations simples limit wc-     | isEmptyBag (wc_simple wc)-     = return (n,wc)--     | otherwise-     = do { -- Solve-            wc1 <- solve_simple_wanteds wc--            -- Run plugins-          ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1--          ; if rerun_plugin-            then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin)-                    ; go (n+1) limit wc2 }   -- Loop-            else return (n, wc2) }           -- Done---solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints--- Try solving these constraints--- Affects the unification state (of course) but not the inert set--- The result is not necessarily zonked-solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_errors = errs })-  = nestTcS $-    do { solveSimples simples1-       ; (implics2, unsolved) <- getUnsolvedInerts-       ; return (WC { wc_simple = unsolved-                    , wc_impl   = implics1 `unionBags` implics2-                    , wc_errors = errs }) }--{- Note [The solveSimpleWanteds loop]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Solving a bunch of simple constraints is done in a loop,-(the 'go' loop of 'solveSimpleWanteds'):-  1. Try to solve them-  2. Try the plugin-  3. If the plugin wants to run again, go back to step 1--}--{--************************************************************************-*                                                                      *-           Solving flat constraints: solveSimples-*                                                                      *-********************************************************************* -}---- The main solver loop implements Note [Basic Simplifier Plan]-----------------------------------------------------------------solveSimples :: Cts -> TcS ()--- Returns the final InertSet in TcS--- Has no effect on work-list or residual-implications--- The constraints are initially examined in left-to-right order--solveSimples cts-  = {-# SCC "solveSimples" #-}-    do { emitWork cts; solve_loop }-  where-    solve_loop-      = {-# SCC "solve_loop" #-}-        do { sel <- selectNextWorkItem-           ; case sel of-              Nothing -> return ()-              Just ct -> do { solveOne ct-                            ; solve_loop } }--solveOne :: Ct -> TcS ()  -- Solve one constraint-solveOne workItem-  = do { wl      <- getWorkList-       ; inerts  <- getInertSet-       ; tclevel <- getTcLevel-       ; traceTcS "----------------------------- " empty-       ; traceTcS "Start solver pipeline {" $-                  vcat [ text "tclevel =" <+> ppr tclevel-                       , text "work item =" <+> ppr workItem-                       , text "inerts =" <+> ppr inerts-                       , text "rest of worklist =" <+> ppr wl ]--       ; bumpStepCountTcS    -- One step for each constraint processed-       ; solve workItem }-  where-    solve :: Ct -> TcS ()-    solve ct-      = do { traceTcS "solve {" (text "workitem = " <+> ppr ct)-           ; res <- runSolverStage (solveCt ct)-           ; traceTcS "end solve }" (ppr res)-           ; case res of-               StartAgain ct -> do { traceTcS "Go round again" (ppr ct)-                                   ; solve ct }--               Stop ev s -> do { traceFireTcS ev s-                               ; traceTcS "End solver pipeline }" empty-                               ; return () }--               -- ContinueWith can't happen: res :: SolverStage Void-               -- solveCt either solves the constraint, or puts-               -- the unsolved constraint in the inert set.-            }--{- *********************************************************************-*                                                                      *-*              Solving one constraint: solveCt-*                                                                      *-************************************************************************--Note [Canonicalization]-~~~~~~~~~~~~~~~~~~~~~~~-Canonicalization converts a simple constraint to a canonical form. It is-unary (i.e. treats individual constraints one at a time).--Constraints originating from user-written code come into being as-CNonCanonicals. We know nothing about these constraints. So, first:--     Classify CNonCanoncal constraints, depending on whether they-     are equalities, class predicates, or other.--Then proceed depending on the shape of the constraint. Generally speaking,-each constraint gets rewritten and then decomposed into one of several forms-(see type Ct in GHC.Tc.Types).--When an already-canonicalized constraint gets kicked out of the inert set,-it must be recanonicalized. But we know a bit about its shape from the-last time through, so we can skip the classification step.--}--solveCt :: Ct -> SolverStage Void--- The Void result tells us that solveCt cannot return--- a ContinueWith; it must return Stop or StartAgain.-solveCt (CNonCanonical ev)                   = solveNC ev-solveCt (CIrredCan (IrredCt { ir_ev = ev })) = solveNC ev--solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel-                           , eq_lhs = lhs, eq_rhs = rhs }))-  = solveEquality ev eq_rel (canEqLHSType lhs) rhs--solveCt (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))-  = do { ev <- rewriteEvidence ev-         -- It is (much) easier to rewrite and re-classify than to-         -- rewrite the pieces and build a Reduction that will rewrite-         -- the whole constraint-       ; case classifyPredType (ctEvPred ev) of-           ForAllPred tvs th p -> Stage $ solveForAll ev tvs th p pend_sc-           _ -> pprPanic "SolveCt" (ppr ev) }--solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc }))-  = do { ev <- rewriteEvidence ev-         -- It is easier to rewrite and re-classify than to rewrite-         -- the pieces and build a Reduction that will rewrite the-         -- whole constraint-       ; case classifyPredType (ctEvPred ev) of-           ClassPred cls tys-             -> solveDict (DictCt { di_ev = ev, di_cls = cls-                                  , di_tys = tys, di_pend_sc = pend_sc })-           _ -> pprPanic "solveCt" (ppr ev) }---------------------solveNC :: CtEvidence -> SolverStage Void-solveNC ev-  = -- Instead of rewriting the evidence before classifying, it's possible we-    -- can make progress without the rewrite. Try this first.-    -- For insolubles (all of which are equalities), do /not/ rewrite the arguments-    -- In #14350 doing so led entire-unnecessary and ridiculously large-    -- type function expansion.  Instead, canEqNC just applies-    -- the substitution to the predicate, and may do decomposition;-    --    e.g. a ~ [a], where [G] a ~ [Int], can decompose-    case classifyPredType (ctEvPred ev) of {-        EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 ;-        _ ->--    -- Do rewriting on the constraint, especially zonking-    do { ev <- rewriteEvidence ev-       ; let irred = IrredCt { ir_ev = ev, ir_reason = IrredShapeReason }--    -- And then re-classify-       ; case classifyPredType (ctEvPred ev) of-           ClassPred cls tys     -> solveDictNC ev cls tys-           ForAllPred tvs th p   -> Stage $ solveForAllNC ev tvs th p-           IrredPred {}          -> solveIrred irred-           EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2-              -- This case only happens if (say) `c` is unified with `a ~# b`,-              -- but that is rare becuase it requires c :: CONSTRAINT UnliftedRep--    }}---{- *********************************************************************-*                                                                      *-*                      Quantified constraints-*                                                                      *-********************************************************************* -}--{- Note [Quantified constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The -XQuantifiedConstraints extension allows type-class contexts like this:--  data Rose f x = Rose x (f (Rose f x))--  instance (Eq a, forall b. Eq b => Eq (f b))-        => Eq (Rose f a)  where-    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2--Note the (forall b. Eq b => Eq (f b)) in the instance contexts.-This quantified constraint is needed to solve the- [W] (Eq (f (Rose f x)))-constraint which arises form the (==) definition.--The wiki page is-  https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints-which in turn contains a link to the GHC Proposal where the change-is specified, and a Haskell Symposium paper about it.--We implement two main extensions to the design in the paper:-- 1. We allow a variable in the instance head, e.g.-      f :: forall m a. (forall b. m b) => D (m a)-    Notice the 'm' in the head of the quantified constraint, not-    a class.-- 2. We support superclasses to quantified constraints.-    For example (contrived):-      f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool-      f x y = x==y-    Here we need (Eq (m a)); but the quantified constraint deals only-    with Ord.  But we can make it work by using its superclass.--Here are the moving parts-  * Language extension {-# LANGUAGE QuantifiedConstraints #-}-    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension--  * A new form of evidence, EvDFun, that is used to discharge-    such wanted constraints--  * checkValidType gets some changes to accept forall-constraints-    only in the right places.--  * Predicate.Pred gets a new constructor ForAllPred, and-    and classifyPredType analyses a PredType to decompose-    the new forall-constraints--  * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts,-    which holds all the Given forall-constraints.  In effect,-    such Given constraints are like local instance decls.--  * When trying to solve a class constraint, via-    GHC.Tc.Solver.Instance.Class.matchInstEnv, use the InstEnv from inert_insts-    so that we include the local Given forall-constraints-    in the lookup.  (See GHC.Tc.Solver.Monad.getInstEnvs.)--  * `solveForAll` deals with solving a forall-constraint.  See-       Note [Solving a Wanted forall-constraint]--  * We augment the kick-out code to kick out an inert-    forall constraint if it can be rewritten by a new-    type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable--Note that a quantified constraint is never /inferred/-(by GHC.Tc.Solver.simplifyInfer).  A function can only have a-quantified constraint in its type if it is given an explicit-type signature.---}--solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType-              -> TcS (StopOrContinue Void)--- NC: this came from CNonCanonical, so we have not yet expanded superclasses--- Precondition: already rewritten by inert set-solveForAllNC ev tvs theta pred-  | isGiven ev  -- See Note [Eagerly expand given superclasses]-  , Just (cls, tys) <- cls_pred_tys_maybe-  = do { dflags <- getDynFlags-       ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys-       -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]-       ; emitWork (listToBag sc_cts)-       ; solveForAll ev tvs theta pred doNotExpand }-       -- doNotExpand: as we have already (eagerly) expanded superclasses for this class--  | otherwise-  = do { dflags <- getDynFlags-       ; let fuel | Just (cls, _) <- cls_pred_tys_maybe-                  , classHasSCs cls = qcsFuel dflags-                  -- See invariants (a) and (b) in QCI.qci_pend_sc-                  -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]-                  -- See Note [Quantified constraints]-                  | otherwise = doNotExpand-       ; solveForAll ev tvs theta pred fuel }-  where-    cls_pred_tys_maybe = getClassPredTys_maybe pred--solveForAll :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> ExpansionFuel-            -> TcS (StopOrContinue Void)--- Precondition: already rewritten by inert set-solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })-            tvs theta pred _fuel-  = -- See Note [Solving a Wanted forall-constraint]-    setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $-    -- This setSrcSpan is important: the emitImplicationTcS uses that-    -- TcLclEnv for the implication, and that in turn sets the location-    -- for the Givens when solving the constraint (#21006)-    do { let empty_subst = mkEmptySubst $ mkInScopeSet $-                           tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs-             is_qc = IsQC (ctLocOrigin loc)--         -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]-         --           in GHC.Tc.Utils.TcType-         -- Very like the code in tcSkolDFunType-       ; rec { skol_info <- mkSkolemInfo skol_info_anon-             ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs-             ; let inst_pred  = substTy    subst pred-                   inst_theta = substTheta subst theta-                   skol_info_anon = InstSkol is_qc (get_size inst_pred) }--       ; given_ev_vars <- mapM newEvVar inst_theta-       ; (lvl, (w_id, wanteds))-             <- pushLevelNoWorkList (ppr skol_info) $-                do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc)-                         -- Set the thing to prove to have a ScOrigin, so we are-                         -- careful about its termination checks.-                         -- See (QC-INV) in Note [Solving a Wanted forall-constraint]-                   ; wanted_ev <- newWantedEvVarNC loc' rewriters inst_pred-                   ; return ( ctEvEvId wanted_ev-                            , unitBag (mkNonCanonical wanted_ev)) }--      ; ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds--      ; setWantedEvTerm dest EvCanonical $-        EvFun { et_tvs = skol_tvs, et_given = given_ev_vars-              , et_binds = ev_binds, et_body = w_id }--      ; stopWith ev "Wanted forall-constraint" }-  where-    -- Getting the size of the head is a bit horrible-    -- because of the special treament for class predicates-    get_size pred = case classifyPredType pred of-                      ClassPred cls tys -> pSizeClassPred cls tys-                      _                 -> pSizeType pred-- -- See Note [Solving a Given forall-constraint]-solveForAll ev@(CtGiven {}) tvs _theta pred fuel-  = do { addInertForAll qci-       ; stopWith ev "Given forall-constraint" }-  where-    qci = QCI { qci_ev = ev, qci_tvs = tvs-              , qci_pred = pred, qci_pend_sc = fuel }--{- Note [Solving a Wanted forall-constraint]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Solving a wanted forall (quantified) constraint-  [W] df :: forall ab. (Eq a, Ord b) => C x a b-is delightfully easy.   Just build an implication constraint-    forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a-and discharge df thus:-    df = /\ab. \g1 g2. let <binds> in d-where <binds> is filled in by solving the implication constraint.-All the machinery is to hand; there is little to do.--The tricky point is about termination: see #19690.  We want to maintain-the invariant (QC-INV):--  (QC-INV) Every quantified constraint returns a non-bottom dictionary--just as every top-level instance declaration guarantees to return a non-bottom-dictionary.  But as #19690 shows, it is possible to get a bottom dicionary-by superclass selection if we aren't careful.  The situation is very similar-to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance;-and we use the same solution:--* Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size))-* Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc)--Both of these things are done in solveForAll.  Now the mechanism described-in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over.--Note [Solving a Given forall-constraint]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For a Given constraint-  [G] df :: forall ab. (Eq a, Ord b) => C x a b-we just add it to TcS's local InstEnv of known instances,-via addInertForall.  Then, if we look up (C x Int Bool), say,-we'll find a match in the InstEnv.---************************************************************************-*                                                                      *-                  Evidence transformation-*                                                                      *-************************************************************************--}--rewriteEvidence :: CtEvidence -> SolverStage CtEvidence--- (rewriteEvidence old_ev new_pred co do_next)--- Main purpose: create new evidence for new_pred;---                 unless new_pred is cached already--- * Calls do_next with (new_ev :: new_pred), with same wanted/given flag as old_ev--- * If old_ev was wanted, create a binding for old_ev, in terms of new_ev--- * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev--- * Stops if new_ev is already cached------        Old evidence    New predicate is               Return new evidence---        flavour                                        of same flavor---        ----------------------------------------------------------------------        Wanted          Already solved or in inert     Stop---                        Not                            do_next new_evidence------        Given           Already in inert               Stop---                        Not                            do_next new_evidence--{- Note [Rewriting with Refl]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the coercion is just reflexivity then you may re-use the same-evidence variable.  But be careful!  Although the coercion is Refl, new_pred-may reflect the result of unification alpha := ty, so new_pred might-not _look_ the same as old_pred, and it's vital to proceed from now on-using new_pred.--The rewriter preserves type synonyms, so they should appear in new_pred-as well as in old_pred; that is important for good error messages.--If we are rewriting with Refl, then there are no new rewriters to add to-the rewriter set. We check this with an assertion.- -}---rewriteEvidence ev-  = Stage $ do { traceTcS "rewriteEvidence" (ppr ev)-               ; (redn, rewriters) <- rewrite ev (ctEvPred ev)-               ; finish_rewrite ev redn rewriters }--finish_rewrite :: CtEvidence   -- ^ old evidence-               -> Reduction    -- ^ new predicate + coercion, of type <type of old evidence> ~ new predicate-               -> RewriterSet  -- ^ See Note [Wanteds rewrite Wanteds]-                               -- in GHC.Tc.Types.Constraint-               -> TcS (StopOrContinue CtEvidence)-finish_rewrite old_ev (Reduction co new_pred) rewriters-  | isReflCo co -- See Note [Rewriting with Refl]-  = assert (isEmptyRewriterSet rewriters) $-    continueWith (setCtEvPredType old_ev new_pred)--finish_rewrite ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })-                (Reduction co new_pred) rewriters-  = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted-    do { new_ev <- newGivenEvVar loc (new_pred, new_tm)-       ; continueWith new_ev }-  where-    -- mkEvCast optimises ReflCo-    ev_rw_role = ctEvRewriteRole ev-    new_tm = assert (coercionRole co == ev_rw_role)-             mkEvCast (evId old_evar)-                (downgradeRole Representational ev_rw_role co)--finish_rewrite ev@(CtWanted { ctev_dest = dest-                             , ctev_loc = loc-                             , ctev_rewriters = rewriters })-                (Reduction co new_pred) new_rewriters-  = do { mb_new_ev <- newWanted loc rewriters' new_pred-       ; let ev_rw_role = ctEvRewriteRole ev-       ; massert (coercionRole co == ev_rw_role)-       ; setWantedEvTerm dest EvCanonical $-            mkEvCast (getEvExpr mb_new_ev)-                     (downgradeRole Representational ev_rw_role (mkSymCo co))-       ; case mb_new_ev of-            Fresh  new_ev -> continueWith new_ev-            Cached _      -> stopWith ev "Cached wanted" }-  where-    rewriters' = rewriters S.<> new_rewriters--{- *******************************************************************-*                                                                    *-*                      Typechecker plugins-*                                                                    *-******************************************************************* -}---- | Extract the (inert) givens and invoke the plugins on them.--- Remove solved givens from the inert set and emit insolubles, but--- return new work produced so that 'solveSimpleGivens' can feed it back--- into the main solver.-runTcPluginsGiven :: TcS [Ct]-runTcPluginsGiven-  = do { solvers <- getTcPluginSolvers-       ; if null solvers then return [] else-    do { givens <- getInertGivens-       ; if null givens then return [] else-    do { traceTcS "runTcPluginsGiven {" (ppr givens)-       ; p <- runTcPluginSolvers solvers (givens,[])-       ; let (solved_givens, _) = pluginSolvedCts p-             insols             = map (ctIrredCt PluginReason) (pluginBadCts p)-       ; updInertCans (removeInertCts solved_givens .-                       updIrreds (addIrreds insols) )-       ; traceTcS "runTcPluginsGiven }" $-         vcat [ text "solved_givens:" <+> ppr solved_givens-              , text "insols:" <+> ppr insols-              , text "new:" <+> ppr (pluginNewCts p) ]-       ; return (pluginNewCts p) } } }---- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on--- them and produce an updated bag of wanteds (possibly with some new--- work) and a bag of insolubles.  The boolean indicates whether--- 'solveSimpleWanteds' should feed the updated wanteds back into the--- main solver.-runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints)-runTcPluginsWanted wc@(WC { wc_simple = simples1 })-  | isEmptyBag simples1-  = return (False, wc)-  | otherwise-  = do { solvers <- getTcPluginSolvers-       ; if null solvers then return (False, wc) else--    do { given <- getInertGivens-       ; wanted <- zonkSimples simples1    -- Plugin requires zonked inputs--       ; traceTcS "Running plugins (" (vcat [ text "Given:" <+> ppr given-                                            , text "Watned:" <+> ppr wanted ])-       ; p <- runTcPluginSolvers solvers (given, bagToList wanted)-       ; let (_, solved_wanted)   = pluginSolvedCts p-             (_, unsolved_wanted) = pluginInputCts p-             new_wanted     = pluginNewCts p-             insols         = pluginBadCts p-             all_new_wanted = listToBag new_wanted       `andCts`-                              listToBag unsolved_wanted  `andCts`-                              listToBag insols---- SLPJ: I'm deeply suspicious of this---       ; updInertCans (removeInertCts $ solved_givens)--       ; mapM_ setEv solved_wanted--       ; traceTcS "Finished plugins }" (ppr new_wanted)-       ; return ( notNull (pluginNewCts p)-                , wc { wc_simple = all_new_wanted } ) } }-  where-    setEv :: (EvTerm,Ct) -> TcS ()-    setEv (ev,ct) = case ctEvidence ct of-      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest EvCanonical ev-           -- TODO: plugins should be able to signal non-canonicity-      _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"---- | A pair of (given, wanted) constraints to pass to plugins-type SplitCts  = ([Ct], [Ct])---- | A solved pair of constraints, with evidence for wanteds-type SolvedCts = ([Ct], [(EvTerm,Ct)])---- | Represents collections of constraints generated by typechecker--- plugins-data TcPluginProgress = TcPluginProgress-    { pluginInputCts  :: SplitCts-      -- ^ Original inputs to the plugins with solved/bad constraints-      -- removed, but otherwise unmodified-    , pluginSolvedCts :: SolvedCts-      -- ^ Constraints solved by plugins-    , pluginBadCts    :: [Ct]-      -- ^ Constraints reported as insoluble by plugins-    , pluginNewCts    :: [Ct]-      -- ^ New constraints emitted by plugins-    }--getTcPluginSolvers :: TcS [TcPluginSolver]-getTcPluginSolvers-  = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) }---- | Starting from a pair of (given, wanted) constraints,--- invoke each of the typechecker constraint-solving plugins in turn and return------  * the remaining unmodified constraints,---  * constraints that have been solved,---  * constraints that are insoluble, and---  * new work.------ Note that new work generated by one plugin will not be seen by--- other plugins on this pass (but the main constraint solver will be--- re-invoked and they will see it later).  There is no check that new--- work differs from the original constraints supplied to the plugin:--- the plugin itself should perform this check if necessary.-runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress-runTcPluginSolvers solvers all_cts-  = do { ev_binds_var <- getTcEvBindsVar-       ; foldM (do_plugin ev_binds_var) initialProgress solvers }-  where-    do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress-    do_plugin ev_binds_var p solver = do-        result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p))-        return $ progress p result--    progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress-    progress p-      (TcPluginSolveResult-        { tcPluginInsolubleCts = bad_cts-        , tcPluginSolvedCts    = solved_cts-        , tcPluginNewCts       = new_cts-        }-      ) =-        p { pluginInputCts  = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p)-          , pluginSolvedCts = add solved_cts (pluginSolvedCts p)-          , pluginNewCts    = new_cts ++ pluginNewCts p-          , pluginBadCts    = bad_cts ++ pluginBadCts p-          }--    initialProgress = TcPluginProgress all_cts ([], []) [] []--    discard :: [Ct] -> SplitCts -> SplitCts-    discard cts (xs, ys) =-        (xs `without` cts, ys `without` cts)--    without :: [Ct] -> [Ct] -> [Ct]-    without = deleteFirstsBy eq_ct--    eq_ct :: Ct -> Ct -> Bool-    eq_ct c c' = ctFlavour c == ctFlavour c'-              && ctPred c `tcEqType` ctPred c'--    add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts-    add xs scs = foldl' addOne scs xs--    addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts-    addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of-      CtGiven  {} -> (ct:givens, wanteds)-      CtWanted {} -> (givens, (ev,ct):wanteds)--+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecursiveDo #-}++module GHC.Tc.Solver.Solve (+     simplifyWantedsTcM,+     solveWanteds,        -- Solves WantedConstraints+     solveSimpleGivens,   -- Solves [Ct]+     solveSimpleWanteds,  -- Solves Cts+     trySolveImplication,++     setImplicationStatus+  ) where++import GHC.Prelude++import GHC.Tc.Solver.Dict+import GHC.Tc.Solver.Equality( solveEquality )+import GHC.Tc.Solver.Irred( solveIrred )+import GHC.Tc.Solver.Rewrite( rewrite, rewriteType )+import GHC.Tc.Errors.Types+import GHC.Tc.Utils.TcType+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.CtLoc( ctLocEnv, ctLocOrigin, setCtLocOrigin )+import GHC.Tc.Types+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.CtLoc( mkGivenLoc )+import GHC.Tc.Solver.InertSet+import GHC.Tc.Solver.Monad  as TcS+import qualified GHC.Tc.Utils.Monad   as TcM+import qualified GHC.Tc.Zonk.TcType   as TcM++import GHC.Core.Predicate+import GHC.Core.Reduction+import GHC.Core.Coercion+import GHC.Core.TyCo.FVs( coVarsOfCos )+import GHC.Core.Class( classHasSCs )++import GHC.Types.Id(  idType )+import GHC.Types.Var( EvVar, tyVarKind )+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Basic ( IntWithInf, intGtLimit )+import GHC.Types.Unique.Set( nonDetStrictFoldUniqSet )++import GHC.Data.Bag++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Driver.Session+++import Control.Monad++import Data.List( deleteFirstsBy )+import Data.Maybe ( mapMaybe )+import qualified Data.Semigroup as S+import Data.Void( Void )++{- ********************************************************************************+*                                                                                 *+*                                 Main Simplifier                                 *+*                                                                                 *+******************************************************************************** -}++simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints+-- Solve the specified Wanted constraints+-- Discard the evidence binds+-- Postcondition: fully zonked+simplifyWantedsTcM wanted+  = do { TcM.traceTc "simplifyWantedsTcM {" (ppr wanted)+       ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted))+       ; result <- TcM.liftZonkM $ TcM.zonkWC result+       ; TcM.traceTc "simplifyWantedsTcM }" (ppr result)+       ; return result }++solveWanteds :: WantedConstraints -> TcS WantedConstraints+solveWanteds wc@(WC { wc_errors = errs })+  = do { cur_lvl <- TcS.getTcLevel+       ; traceTcS "solveWanteds {" $+         vcat [ text "Level =" <+> ppr cur_lvl+              , ppr wc ]++       ; dflags <- getDynFlags+       ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc++       ; errs' <- simplifyDelayedErrors errs+       ; let final_wc = solved_wc { wc_errors = errs' }++       ; ev_binds_var <- getTcEvBindsVar+       ; bb <- TcS.getTcEvBindsMap ev_binds_var+       ; traceTcS "solveWanteds }" $+                 vcat [ text "final wc =" <+> ppr final_wc+                      , text "ev_binds_var =" <+> ppr ev_binds_var+                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]++       ; return final_wc }++simplify_loop :: Int -> IntWithInf -> Bool+              -> WantedConstraints -> TcS WantedConstraints+-- Do a round of solving, and call maybe_simplify_again to iterate+-- The 'definitely_redo_implications' flags is False if the only reason we+-- are iterating is that we have added some new Wanted superclasses+-- hoping for fundeps to help us; see Note [Superclass iteration]+--+-- Does not affect wc_holes at all; reason: wc_holes never affects anything+-- else, so we do them once, at the end in solveWanteds+simplify_loop n limit definitely_redo_implications+              wc@(WC { wc_simple = simples, wc_impl = implics })+  | isSolvedWC wc  -- Fast path+  = return wc+  | otherwise+  = do { csTraceTcS $+         text "simplify_loop iteration=" <> int n+         <+> (parens $ hsep [ text "definitely_redo =" <+> ppr definitely_redo_implications <> comma+                            , int (lengthBag simples) <+> text "simples to solve" ])+       ; traceTcS "simplify_loop: wc =" (ppr wc)++       ; (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.InertSet++       -- Next, solve implications from wc_impl+       ; implics' <- if not definitely_redo_implications  -- See Note [Superclass iteration]+                        && unifs1 == 0                    -- for this conditional+                    then return implics+                    else solveNestedImplications implics++       ; let wc' = wc1 { wc_impl = wc_impl wc1 `unionBags` implics' }++       ; unif_happened <- resetUnificationFlag+       ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened+         -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad+       ; maybe_simplify_again (n+1) limit unif_happened wc' }++maybe_simplify_again :: Int -> IntWithInf -> Bool+                     -> WantedConstraints -> TcS WantedConstraints+maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples })+  | n `intGtLimit` limit+  = do { -- Add an error (not a warning) if we blow the limit,+         -- Typically if we blow the limit we are going to report some other error+         -- (an unsolved constraint), and we don't want that error to suppress+         -- the iteration limit warning!+         addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc+       ; return wc }++  | unif_happened+  = simplify_loop n limit True wc++  | superClassesMightHelp wc    -- Returns False quickly if wc is solved+  = -- We still have unsolved goals, and apparently no way to solve them,+    -- so try expanding superclasses at this level, both Given and Wanted+    do { pending_given <- getPendingGivenScs+       ; let (pending_wanted, simples1) = getPendingWantedScs simples+       ; if null pending_given && null pending_wanted+           then return wc  -- After all, superclasses did not help+           else+    do { new_given  <- makeSuperClasses pending_given+       ; new_wanted <- makeSuperClasses pending_wanted+       ; solveSimpleGivens new_given -- Add the new Givens to the inert set+       ; traceTcS "maybe_simplify_again" (vcat [ text "pending_given" <+> ppr pending_given+                                               , text "new_given" <+> ppr new_given+                                               , text "pending_wanted" <+> ppr pending_wanted+                                               , text "new_wanted" <+> ppr new_wanted ])+       ; simplify_loop n limit (not (null pending_given)) $+         wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }+         -- (not (null pending_given)): see Note [Superclass iteration]++  | otherwise+  = return wc++{- Note [Superclass iteration]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this implication constraint+    forall a.+       [W] d: C Int beta+       forall b. blah+where+  class D a b | a -> b+  class D a b => C a b+We will expand d's superclasses, giving [W] D Int beta, in the hope of geting+fundeps to unify beta.  Doing so is usually fruitless (no useful fundeps),+and if so it seems a pity to waste time iterating the implications (forall b. blah)+(If we add new Given superclasses it's a different matter: it's really worth looking+at the implications.)++Hence the definitely_redo_implications flag to simplify_loop.  It's usually+True, but False in the case where the only reason to iterate is new Wanted+superclasses.  In that case we check whether the new Wanteds actually led to+any new unifications, and iterate the implications only if so.+-}++{- Note [Expanding Recursive Superclasses and ExpansionFuel]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the class declaration (T21909)++    class C [a] => C a where+       foo :: a -> Int++and suppose during type inference we obtain an implication constraint:++    forall a. C a => C [[a]]++To solve this implication constraint, we first expand one layer of the superclass+of Given constraints, but not for Wanted constraints.+(See Note [Eagerly expand given superclasses] and Note [Why adding superclasses can help]+in GHC.Tc.Solver.Dict.) We thus get:++    [G] g1 :: C a+    [G] g2 :: C [a]    -- new superclass layer from g1+    [W] w1 :: C [[a]]++Now, we cannot solve `w1` directly from `g1` or `g2` as we may not have+any instances for C. So we expand a layer of superclasses of each Wanteds and Givens+that we haven't expanded yet.+This is done in `maybe_simplify_again`. And we get:++    [G] g1 :: C a+    [G] g2 :: C [a]+    [G] g3 :: C [[a]]    -- new superclass layer from g2, can solve w1+    [W] w1 :: C [[a]]+    [W] w2 :: C [[[a]]]  -- new superclass layer from w1, not solvable++Now, although we can solve `w1` using `g3` (obtained from expanding `g2`),+we have a new wanted constraint `w2` (obtained from expanding `w1`) that cannot be solved.+We thus make another go at solving in `maybe_simplify_again` by expanding more+layers of superclasses. This looping is futile as Givens will never be able to catch up with Wanteds.++Side Note: In principle we don't actually need to /solve/ `w2`, as it is a superclass of `w1`+but we only expand it to expose any functional dependencies (see Note [The superclass story])+But `w2` is a wanted constraint, so we will try to solve it like any other,+even though ultimately we will discard its evidence.++Solution: Simply bound the maximum number of layers of expansion for+Givens and Wanteds, with ExpansionFuel.  Give the Givens more fuel+(say 3 layers) than the Wanteds (say 1 layer). Now the Givens will+win.  The Wanteds don't need much fuel: we are only expanding at all+to expose functional dependencies, and wantedFuel=1 means we will+expand a full recursive layer.  If the superclass hierarchy is+non-recursive (the normal case) one layer is therefore full expansion.++The default value for wantedFuel = Constants.max_WANTEDS_FUEL = 1.+The default value for givenFuel  = Constants.max_GIVENS_FUEL = 3.+Both are configurable via the `-fgivens-fuel` and `-fwanteds-fuel`+compiler flags.++There are two preconditions for the default fuel values:+   (1) default givenFuel >= default wantedsFuel+   (2) default givenFuel < solverIterations++Precondition (1) ensures that we expand givens at least as many times as we expand wanted constraints+preferably givenFuel > wantedsFuel to avoid issues like T21909 while+the precondition (2) ensures that we do not reach the solver iteration limit and fail with a+more meaningful error message (see T19627)++This also applies for quantified constraints; see `-fqcs-fuel` compiler flag and `QCI.qci_pend_sc` field.+-}++{- ********************************************************************************+*                                                                                 *+*                    Solving implication constraints                              *+*                                                                                 *+******************************************************************************** -}++solveNestedImplications :: Bag Implication+                        -> TcS (Bag Implication)+-- Precondition: the TcS inerts may contain unsolved simples which have+-- to be converted to givens before we go inside a nested implication.+solveNestedImplications implics+  | isEmptyBag implics+  = return (emptyBag)+  | otherwise+  = do { traceTcS "solveNestedImplications starting {" empty+       ; unsolved_implics <- mapBagM solveImplication implics++       -- ... and we are back in the original TcS inerts+       -- Notice that the original includes the _insoluble_simples so it was safe to ignore+       -- them in the beginning of this function.+       ; traceTcS "solveNestedImplications end }" $+                  vcat [ text "unsolved_implics =" <+> ppr unsolved_implics ]++       ; return unsolved_implics }++{- Note [trySolveImplication]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`trySolveImplication` may be invoked while solving simple wanteds, notably from+`solveWantedForAll`.  It returns a Bool to say if solving succeeded or failed.++It uses `nestImplicTcS` to build a nested scope.  One subtle point is that+`nestImplicTcS` uses the `inert_givens` (not the `inert_cans`) of the current+inert set to initialse the `InertSet` of the nested scope.  It is super-important not+to pollute the sub-solving problem with the unsolved Wanteds of the current scope.++Whenever we do `solveSimpleGivens`, we snapshot the `inert_cans` into `inert_givens`.+(At that moment there should be no Wanteds.)+-}++trySolveImplication :: Implication -> TcS Bool+-- See Note [trySolveImplication]+trySolveImplication (Implic { ic_tclvl  = tclvl+                            , ic_binds  = ev_binds_var+                            , ic_given  = given_ids+                            , ic_wanted = wanteds+                            , ic_env    = ct_loc_env+                            , ic_info   = info })+  = nestImplicTcS ev_binds_var tclvl $+    do { let loc    = mkGivenLoc tclvl info ct_loc_env+             givens = mkGivens loc given_ids+       ; solveSimpleGivens givens+       ; residual_wanted <- solveWanteds wanteds+       ; return (isSolvedWC residual_wanted) }++solveImplication :: Implication     -- Wanted+                 -> TcS Implication -- Simplified implication+-- Precondition: The TcS monad contains an empty worklist and given-only inerts+-- which after trying to solve this implication we must restore to their original value+solveImplication imp@(Implic { ic_tclvl  = tclvl+                             , ic_binds  = ev_binds_var+                             , ic_given  = given_ids+                             , ic_wanted = wanteds+                             , ic_info   = info+                             , ic_env    = ct_loc_env+                             , ic_status = status })+  | isSolvedStatus status+  = return imp  -- Do nothing++  | otherwise  -- Even for IC_Insoluble it is worth doing more work+               -- The insoluble stuff might be in one sub-implication+               -- and other unsolved goals in another; and we want to+               -- solve the latter as much as possible+  = do { inerts <- getInertSet+       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)++       -- commented out; see `where` clause below+       -- ; when debugIsOn check_tc_level++         -- Solve the nested constraints+       ; (has_given_eqs, given_insols, residual_wanted)+            <- nestImplicTcS ev_binds_var tclvl $+               do { let loc    = mkGivenLoc tclvl info ct_loc_env+                        givens = mkGivens loc given_ids+                  ; solveSimpleGivens givens++                  ; residual_wanted <- solveWanteds wanteds++                  ; (has_eqs, given_insols) <- getHasGivenEqs tclvl+                        -- Call getHasGivenEqs /after/ solveWanteds, because+                        -- solveWanteds can augment the givens, via expandSuperClasses,+                        -- to reveal given superclass equalities++                  ; return (has_eqs, given_insols, residual_wanted) }++       ; traceTcS "solveImplication 2"+           (ppr given_insols $$ ppr residual_wanted)++       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var+       ; traceTcS "solveImplication 3" $ vcat+             [ text "ev_binds_var" <+> ppr ev_binds_var+             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) ]++       ; let final_wanted = residual_wanted `addInsols` given_insols+             -- Don't lose track of the insoluble givens,+             -- which signal unreachable code; put them in ic_wanted++       ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs+                                                 , ic_wanted = final_wanted })++       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var+       ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var+       ; traceTcS "solveImplication end }" $ vcat+             [ text "has_given_eqs =" <+> ppr has_given_eqs+             , text "res_implic =" <+> ppr res_implic+             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)+             , text "implication tvcs =" <+> ppr tcvs ]++       ; return res_implic }++    -- TcLevels must be strictly increasing (see (ImplicInv) in+    -- Note [TcLevel invariants] in GHC.Tc.Utils.TcType),+    -- and in fact I think they should always increase one level at a time.++    -- Though sensible, this check causes lots of testsuite failures. It is+    -- remaining commented out for now.+    {-+    check_tc_level = do { cur_lvl <- TcS.getTcLevel+                        ; massertPpr (tclvl == pushTcLevel cur_lvl)+                                     (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) }+    -}++----------------------+setImplicationStatus :: Implication -> TcS Implication+-- Finalise the implication returned from solveImplication,+--   * Set the ic_status field+--   * Prune unnecessary evidence bindings+--   * Prune unnecessary child implications+-- Precondition: the ic_status field is not already IC_Solved+setImplicationStatus implic@(Implic { ic_status = old_status+                                    , ic_info   = info+                                    , ic_wanted = wc })+ = assertPpr (not (isSolvedStatus old_status)) (ppr info) $+   -- Precondition: we only set the status if it is not already solved+   do { traceTcS "setImplicationStatus {" (ppr implic)++      ; let solved = isSolvedWC wc+      ; new_implic    <- neededEvVars implic+      ; bad_telescope <- if solved then checkBadTelescope implic+                                   else return False++      ; let new_status | insolubleWC wc = IC_Insoluble+                       | not solved     = IC_Unsolved+                       | bad_telescope  = IC_BadTelescope+                       | otherwise      = IC_Solved { ics_dead = dead_givens }+            dead_givens = findRedundantGivens new_implic+            new_wc      = pruneImplications wc++            final_implic = new_implic { ic_status = new_status+                                      , ic_wanted = new_wc }++      ; traceTcS "setImplicationStatus }" (ppr final_implic)+      ; return final_implic }++pruneImplications :: WantedConstraints -> WantedConstraints+-- We have now recorded the `ic_need` variables of the child+-- implications (in `ic_need_implics` of the parent) so we can+-- delete any unnecessary children.+pruneImplications wc@(WC { wc_impl = implics })+  = wc { wc_impl = filterBag keep_me implics }+         -- Do not prune holes; these should be reported+  where+    keep_me :: Implication -> Bool+    keep_me (Implic { ic_status = status, ic_wanted = wanted })+      | IC_Solved { ics_dead = dead_givens } <- status -- Fully solved+      , null dead_givens                               -- No redundant givens to report+      , isEmptyBag (wc_impl wanted)                    -- No children that might have things to report+      = False+      | otherwise+      = True        -- Otherwise, keep it++findRedundantGivens :: Implication -> [EvVar]+findRedundantGivens (Implic { ic_info = info, ic_need = need, ic_given = givens })+  | not (warnRedundantGivens info)   -- Don't report redundant constraints at all+  = []                    -- See (TRC4) of Note [Tracking redundant constraints]++  | not (null unused_givens)         -- Some givens are literally unused+  = unused_givens++  -- Only try this if unused_givens is empty: see (TRC2a)+  | otherwise                       -- All givens are used, but some might+  = redundant_givens                -- still be redundant e.g. (Eq a, Ord a)++  where+    in_instance_decl = case info of { InstSkol {} -> True; _ -> False }+                       -- See Note [Redundant constraints in instance decls]++    unused_givens = filterOut is_used givens++    needed_givens_ignoring_default_methods = ens_fvs need+    is_used given =  is_type_error given+                  || given `elemVarSet` needed_givens_ignoring_default_methods+                  || (in_instance_decl && is_improving (idType given))++    minimal_givens = mkMinimalBySCs evVarPred givens  -- See (TRC2)++    is_minimal = (`elemVarSet` mkVarSet minimal_givens)+    redundant_givens+      | in_instance_decl = []+      | otherwise        = filterOut is_minimal givens++    -- See #15232+    is_type_error id = isTopLevelUserTypeError (idType id)++    is_improving pred -- (transSuperClasses p) does not include p+      = any isImprovementPred (pred : transSuperClasses pred)++warnRedundantGivens :: SkolemInfoAnon -> Bool+warnRedundantGivens (SigSkol ctxt _ _)+  = case ctxt of+       FunSigCtxt _ rrc -> reportRedundantConstraints rrc+       ExprSigCtxt rrc  -> reportRedundantConstraints rrc+       _                -> False++warnRedundantGivens (InstSkol from _)+ -- Do not report redundant constraints for quantified constraints+ -- See (TRC4) in Note [Tracking redundant constraints]+ -- Fortunately it is easy to spot implications constraints that arise+ -- from quantified constraints, from their SkolInfo+ = case from of+      IsQC {}      -> False+      IsClsInst {} -> True++  -- To think about: do we want to report redundant givens for+  -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.+warnRedundantGivens _ = False++{- Note [Redundant constraints in instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instance declarations are special in two ways:++* We don't report unused givens if they can give rise to improvement.+  Example (#10100):+    class Add a b ab | a b -> ab, a ab -> b+    instance Add Zero b b+    instance Add a b ab => Add (Succ a) b (Succ ab)+  The context (Add a b ab) for the instance is clearly unused in terms+  of evidence, since the dictionary has no fields.  But it is still+  needed!  With the context, a wanted constraint+     Add (Succ Zero) beta (Succ Zero)+  we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.+  But without the context we won't find beta := Zero.++  This only matters in instance declarations.++* We don't report givens that are a superclass of another given. E.g.+       class Ord r => UserOfRegs r a where ...+       instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where+  The (Ord r) is not redundant, even though it is a superclass of+  (UserOfRegs r CmmReg).  See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.++  Again this is specific to instance declarations.+-}+++checkBadTelescope :: Implication -> TcS Bool+-- True <=> the skolems form a bad telescope+-- See Note [Checking telescopes] in GHC.Tc.Types.Constraint+checkBadTelescope (Implic { ic_info  = info+                          , ic_skols = skols })+  | checkTelescopeSkol info+  = do{ skols <- mapM TcS.zonkTyCoVarKind skols+      ; return (go emptyVarSet (reverse skols))}++  | otherwise+  = return False++  where+    go :: TyVarSet   -- skolems that appear *later* than the current ones+       -> [TcTyVar]  -- ordered skolems, in reverse order+       -> Bool       -- True <=> there is an out-of-order skolem+    go _ [] = False+    go later_skols (one_skol : earlier_skols)+      | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols+      = True+      | otherwise+      = go (later_skols `extendVarSet` one_skol) earlier_skols++neededEvVars :: Implication -> TcS Implication+-- Find all the evidence variables that are "needed",+-- /and/ delete dead evidence bindings+--+--   See Note [Tracking redundant constraints]+--   See Note [Delete dead Given evidence bindings]+--+--   - Start from initial_seeds (from nested implications)+--+--   - Add free vars of RHS of all Wanted evidence bindings+--     and coercion variables accumulated in tcvs (all Wanted)+--+--   - Generate 'needed', the needed set of EvVars, by doing transitive+--     closure through Given bindings+--     e.g.   Needed {a,b}+--            Given  a = sc_sel a2+--            Then a2 is needed too+--+--   - Prune out all Given bindings that are not needed++neededEvVars implic@(Implic { ic_info        = info+                            , ic_binds       = ev_binds_var+                            , ic_wanted      = WC { wc_impl = implics }+                            , ic_need_implic = old_need_implic    -- See (TRC1)+                    })+ = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var+      ; used_cos <- TcS.getTcEvTyCoVars ev_binds_var++      ; let -- Find the variables needed by `implics`+            new_need_implic@(ENS { ens_dms = dm_seeds, ens_fvs = other_seeds })+                = foldr add_implic old_need_implic implics+                  -- Start from old_need_implic!  See (TRC1)++            -- Get the variables needed by the solved bindings+            -- (It's OK to use a non-deterministic fold here+            --  because add_wanted is commutative.)+            used_covars = coVarsOfCos used_cos+            seeds_w = nonDetStrictFoldEvBindMap add_wanted used_covars ev_binds++            need_ignoring_dms = findNeededGivenEvVars ev_binds (other_seeds `unionVarSet` seeds_w)+            need_from_dms     = findNeededGivenEvVars ev_binds dm_seeds+            need_full         = need_ignoring_dms `unionVarSet` need_from_dms++            -- `need`: the Givens from outer scopes that are used in this implication+            -- is_dm_skol: see (TRC5)+            need | is_dm_skol info = ENS { ens_dms = trim ev_binds need_full+                                         , ens_fvs = emptyVarSet }+                 | otherwise       = ENS { ens_dms = trim ev_binds need_from_dms+                                         , ens_fvs = trim ev_binds need_ignoring_dms }++      -- Delete dead Given evidence bindings+      -- See Note [Delete dead Given evidence bindings]+      ; let live_ev_binds = filterEvBindMap (needed_ev_bind need_full) ev_binds+      ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds++      ; traceTcS "neededEvVars" $+        vcat [ text "old_need_implic:" <+> ppr old_need_implic+             , text "new_need_implic:" <+> ppr new_need_implic+             , text "used_covars:" <+> ppr used_covars+             , text "need_ignoring_dms:" <+> ppr need_ignoring_dms+             , text "need_from_dms:"     <+> ppr need_from_dms+             , text "need:" <+> ppr need+             , text "ev_binds:" <+> ppr ev_binds+             , text "live_ev_binds:" <+> ppr live_ev_binds ]+      ; return (implic { ic_need        = need+                       , ic_need_implic = new_need_implic }) }+ where+    trim :: EvBindMap -> VarSet -> VarSet+    -- Delete variables bound by Givens or bindings+    trim ev_binds needs = needs `varSetMinusEvBindMap` ev_binds++    add_implic :: Implication -> EvNeedSet -> EvNeedSet+    add_implic (Implic { ic_given = givens, ic_need = need }) acc+       = (need `delGivensFromEvNeedSet` givens) `unionEvNeedSet` acc++    needed_ev_bind needed (EvBind { eb_lhs = ev_var, eb_info = info })+      | EvBindGiven{} <- info = ev_var `elemVarSet` needed+      | otherwise             = True   -- Keep all wanted bindings++    add_wanted :: EvBind -> VarSet -> VarSet+    add_wanted (EvBind { eb_info = info, eb_rhs = rhs }) needs+      | EvBindGiven{} <- info = needs  -- Add the rhs vars of the Wanted bindings only+      | otherwise = nestedEvIdsOfTerm rhs `unionVarSet` needs++    is_dm_skol :: SkolemInfoAnon -> Bool+    is_dm_skol (MethSkol _ is_dm) = is_dm+    is_dm_skol _                  = False++findNeededGivenEvVars :: EvBindMap -> VarSet -> VarSet+-- Find all the Given evidence needed by seeds,+-- looking transitively through bindings for Givens (only)+findNeededGivenEvVars ev_binds seeds+  = transCloVarSet also_needs seeds+  where+   also_needs :: VarSet -> VarSet+   also_needs needs = nonDetStrictFoldUniqSet add emptyVarSet needs+     -- It's OK to use a non-deterministic fold here because we immediately+     -- forget about the ordering by creating a set++   add :: Var -> VarSet -> VarSet+   add v needs+     | Just ev_bind <- lookupEvBind ev_binds v+     , EvBind { eb_info = EvBindGiven, eb_rhs = rhs } <- ev_bind+       -- Look at Given bindings only+     = nestedEvIdsOfTerm rhs `unionVarSet` needs+     | otherwise+     = needs++-------------------------------------------------+simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError)+-- Simplify any delayed errors: e.g. type and term holes+-- NB: At this point we have finished with all the simple+--     constraints; they are in wc_simple, not in the inert set.+--     So those Wanteds will not rewrite these delayed errors.+--     That's probably no bad thing.+--+--     However if we have [W] alpha ~ Maybe a, [W] alpha ~ Int+--     and _ : alpha, then we'll /unify/ alpha with the first of+--     the Wanteds we get, and thereby report (_ : Maybe a) or+--     (_ : Int) unpredictably, depending on which we happen to see+--     first.  Doesn't matter much; there is a type error anyhow.+--     T17139 is a case in point.+simplifyDelayedErrors = mapMaybeBagM simpl_err+  where+    simpl_err :: DelayedError -> TcS (Maybe DelayedError)+    simpl_err (DE_Hole hole) = Just . DE_Hole <$> simpl_hole hole+    simpl_err err@(DE_NotConcrete {}) = return $ Just err+    simpl_err (DE_Multiplicity mult_co loc)+      = do { mult_co' <- TcS.zonkCo mult_co+           ; if isReflexiveCo mult_co' then+               return Nothing+             else+               return $ Just (DE_Multiplicity mult_co' loc) }++    simpl_hole :: Hole -> TcS Hole++     -- See Note [Do not simplify ConstraintHoles]+    simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h++     -- other wildcards should be simplified for printing+     -- we must do so here, and not in the error-message generation+     -- code, because we have all the givens already set up+    simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc })+      = do { ty' <- rewriteType loc ty+           ; traceTcS "simpl_hole" (ppr ty $$ ppr ty')+           ; return (h { hole_ty = ty' }) }++{- Note [Delete dead Given evidence bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As a result of superclass expansion, we speculatively+generate evidence bindings for Givens. E.g.+   f :: (a ~ b) => a -> b -> Bool+   f x y = ...+We'll have+   [G] d1 :: (a~b)+and we'll speculatively generate the evidence binding+   [G] d2 :: (a ~# b) = sc_sel d++Now d2 is available for solving.  But it may not be needed!  Usually+such dead superclass selections will eventually be dropped as dead+code, but:++ * It won't always be dropped (#13032).  In the case of an+   unlifted-equality superclass like d2 above, we generate+       case heq_sc d1 of d2 -> ...+   and we can't (in general) drop that case expression in case+   d1 is bottom.  So it's technically unsound to have added it+   in the first place.++ * Simply generating all those extra superclasses can generate lots of+   code that has to be zonked, only to be discarded later.  Better not+   to generate it in the first place.++   Moreover, if we simplify this implication more than once+   (e.g. because we can't solve it completely on the first iteration+   of simpl_loop), we'll generate all the same bindings AGAIN!++Easy solution: take advantage of the work we are doing to track dead+(unused) Givens, and use it to prune the Given bindings too.  This is+all done by neededEvVars.++This led to a remarkable 25% overall compiler allocation decrease in+test T12227.++But we don't get to discard all redundant equality superclasses, alas;+see #15205.++Note [Do not simplify ConstraintHoles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before printing the inferred value for a type hole (a _ wildcard in+a partial type signature), we simplify it w.r.t. any Givens. This+makes for an easier-to-understand diagnostic for the user.++However, we do not wish to do this for extra-constraint holes. Here is+the example for why (partial-sigs/should_compile/T12844):++  bar :: _ => FooData rngs+  bar = foo++  data FooData rngs++  class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs++  type family Head (xs :: [k]) where Head (x ': xs) = x++GHC correctly infers that the extra-constraints wildcard on `bar`+should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this+constraint as a Given on the implication constraint for `bar`. (This+implication is emitted by emitResidualConstraints.) The Hole for the _+is stored within the implication's WantedConstraints.  When+simplifyHoles is called, that constraint is already assumed as a+Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r,+r'), Foo rngs), which is disastrous.++Furthermore, there is no need to simplify here: extra-constraints wildcards+are filled in with the output of the solver, in chooseInferredQuantifiers+(choose_psig_context), so they are already simplified. (Contrast to normal+type holes, which are just bound to a meta-variable.) Avoiding the poor output+is simple: just don't simplify extra-constraints wildcards.++This is the only reason we need to track ConstraintHole separately+from TypeHole in HoleSort.++See also Note [Extra-constraint holes in partial type signatures]+in GHC.Tc.Gen.HsType.++Note [Tracking redundant constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With Opt_WarnRedundantConstraints, GHC can report which constraints of a type+signature (or instance declaration) are redundant, and can be omitted.  Here is+an overview of how it works.++This is all tested in typecheck/should_compile/T20602 (among others).++How tracking works:++* We maintain the `ic_need` field in an implication:+     ic_need: the set of Given evidence variables that are needed somewhere+              inside this implication; and are bound either by this implication+              or by an enclosing one.++* `setImplicationStatus` does all the work:+  - When the constraint solver finishes solving all the wanteds in+    an implication, it sets its status to IC_Solved++  - `neededEvVars`: computes which evidence variables are needed by an+    implication in `setImplicationStatus`.  A variable is needed if++      a) It is in the ic_need field of this implication, computed in+         a previous call to `setImplicationStatus`; see (TRC1)++      b) It is in the ics_need of a nested implication; see `add_implic`+         in `neededEvVars`++      c) It is free in the RHS of any /Wanted/ EvBind; each such binding+         solves a Wanted, so we want them all.  See `add_wanted` in+         `neededEvVars`++      d) It is free in the RHS of a /Given/ EvBind whose LHS is needed:+         see `findNeededGivenEvVars` called from `neededEvVars`.++  - Next, if the final status is IC_Solved, `setImplicationStatus` uses+    `findRedundantGivens` to decide which of this implication's Givens+    are redundant.++  - It also uses `pruneImplications` to discard any now-unnecessary child+    implications.++* GHC.Tc.Errors does the actual warning, in `warnRedundantConstraints`.+++Wrinkles:++(TRC1) `pruneImplications` drops any sub-implications of an Implication+  that are irrelevant for error reporting:+      - no unsolved wanteds+      - no sub-implications+      - no redundant givens to report+  But in doing so we must not lose track of the variables that those implications+  needed!  So we track the ic_needs of all child implications in `ic_need_implics`.+  Crucially, this set includes things need by child implications that have been+  discarded by `pruneImplications`.++(TRC2) A Given can be redundant because it is implied by other Givens+         f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary+         g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary+   We nail this by using `mkMinimalBySCs` in `findRedundantGivens`.+   (TRC2a) But NOTE that we only attempt this mkMinimalBySCs stuff if all Givens+   used by evidence bindings.  Example:+      f :: (Eq a, Ord a) => a -> Bool+      f x = x == x+   We report (Ord a) as unused because it is. But we must not also report (Eq a)+   as unused because it is a superclass of Ord!++(TRC3) When two Givens are the same, prefer one that does not involve superclass+  selection, or more generally has shallower superclass-selection depth:+  see 2(b,c) in Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet.+    e.g        f :: (Eq a, Ord a) => a -> Bool+               f x = x == x+  Eager superclass expansion gives us two [G] Eq a constraints. We want to keep+  the one from the user-written Eq a, not the superclass selection. This means+  we report the Ord a as redundant with -Wredundant-constraints, not the Eq a.+  Getting this wrong was #20602.++(TRC4) We don't compute redundant givens for *every* implication; only+  for those which reply True to `warnRedundantGivens`:++   - For example, in a class declaration, the default method *can*+     use the class constraint, but it certainly doesn't *have* to,+     and we don't want to report an error there.  Ditto instance decls.++   - More subtly, in a function definition+       f :: (Ord a, Ord a, Ix a) => a -> a+       f x = rhs+     we do an ambiguity check on the type (which would find that one+     of the Ord a constraints was redundant), and then we check that+     the definition has that type (which might find that both are+     redundant).  We don't want to report the same error twice, so we+     disable it for the ambiguity check.  Hence using two different+     FunSigCtxts, one with the warn-redundant field set True, and the+     other set False in+        - GHC.Tc.Gen.Bind.tcSpecPrag+        - GHC.Tc.Gen.Bind.tcTySig++   - We do not want to report redundant constraints for implications+     that come from quantified constraints.  Example #23323:+        data T a+        instance Show (T a) where ...  -- No context!+        foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int+        bar = foo @T @Eq++     The call to `foo` gives us+       [W] d : (forall a. Eq a => Show (T a))+     To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint:+       forall a. Eq a =>  [W] ds : Show (T a)+     and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a`+     constraint.  But we don't want to report it as redundant!++(TRC5) Consider this (#25992), where `op2` has a default method+        class C a where { op1, op2 :: a -> a+                        ; op2 = op1 . op1 }+        instance C a => C [a] where+          op1 x = x++  Plainly the (C a) constraint is unused; but the expanded decl will look like+        $dmop2 :: C a => a -> a+        $dmop2 = op1 . op1++        $fCList :: forall a. C a => C [a]+        $fCList @a (d::C a) = MkC (\(x:a).x) ($dmop2 @a d)++   Notice that `d` gets passed to `$dmop`: it is "needed".  But it's only+   /really/ needed if some /other/ method (in this case `op1`) uses it.++   So, rather than one set of "needed Givens" we use `EvNeedSet` to track+   a /pair/ of sets:+      ens_dms: needed /only/ by default-method calls+      ens_fvs: needed by something other than a default-method call+   It's a bit of a palaver, but not really difficult.+   All the logic is localised in `neededEvVars`.++   But NOTE that this only applies to /vanilla/ default methods.+   For /generic/ default methods, like+            class D a where { op1 :: blah+                            ; default op1 :: Eq a => blah2 }+   the (Eq a) constraint really is needed (e.g. class NFData and #25992).+   Hence the `Bool` field of `MethSkol` indicates a /vanilla/ default method.++----- Examples++    f, g, h :: (Eq a, Ord a) => a -> Bool+    f x = x == x+    g x = x > x+    h x = x == x && x > x++    All of f,g,h will discover that they have two [G] Eq a constraints: one as+    given and one extracted from the Ord a constraint. They will both discard+    the latter; see (TRC3).++    The body of f uses the [G] Eq a, but not the [G] Ord a. It will report a+    redundant Ord a.++    The body of g uses the [G] Ord a, but not the [G] Eq a. It will report a+    redundant Eq a.++    The body of h uses both [G] Ord a and [G] Eq a; each is used in a solved+    Wanted evidence binding.  But (TRC2) kicks in and discovers the Eq a+    is redundant.++----- Shortcomings++Shortcoming 1.  Consider++  j :: (Eq a, a ~ b) => a -> Bool+  j x = x == x++  k :: (Eq a, b ~ a) => a -> Bool+  k x = x == x++Currently (Nov 2021), j issues no warning, while k says that b ~ a+is redundant. This is because j uses the a ~ b constraint to rewrite+everything to be in terms of b, while k does none of that. This is+ridiculous, but I (Richard E) don't see a good fix.++Shortcoming 2.  Removing a redundant constraint can cause clients to fail to+compile, by making the function more polymorphic. Consider (#16154)++  f :: (a ~ Bool) => a -> Int+  f x = 3++  g :: String -> Int+  g s = f (read s)++The constraint in f's signature is redundant; not used to typecheck+`f`.  And yet if you remove it, `g` won't compile, because there'll+be an ambiguous variable in `g`.+++**********************************************************************+*                                                                    *+*                      Main Solver                                   *+*                                                                    *+**********************************************************************++Note [Basic Simplifier Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+1. Pick an element from the WorkList if there exists one with depth+   less than our context-stack depth.++2. Run it down the 'stage' pipeline. Stages are:+      - canonicalization+      - inert reactions+      - spontaneous reactions+      - top-level interactions+   Each stage returns a StopOrContinue and may have sideeffected+   the inerts or worklist.++   The threading of the stages is as follows:+      - If (Stop) is returned by a stage then we start again from Step 1.+      - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to+        the next stage in the pipeline.+4. If the element has survived (i.e. ContinueWith x) the last stage+   then we add it in the inerts and jump back to Step 1.++If in Step 1 no such element exists, we have exceeded our context-stack+depth and will simply fail.+-}++solveSimpleGivens :: [Ct] -> TcS ()+solveSimpleGivens givens+  | null givens  -- Shortcut for common case+  = return ()+  | otherwise+  = do { traceTcS "solveSimpleGivens {" (ppr givens)+       ; go givens++       -- Capture the Givens in the inert_givens of the inert set+       -- for use by subsequent calls of nestImplicTcS+       -- See Note [trySolveImplication]+       ; updInertSet (\is -> is { inert_givens = inert_cans is })++       ; cans <- getInertCans+       ; traceTcS "End solveSimpleGivens }" (ppr cans) }+  where+    go givens = do { solveSimples (listToBag givens)+                   ; new_givens <- runTcPluginsGiven+                   ; when (notNull new_givens) $+                     go new_givens }++solveSimpleWanteds :: Cts -> TcS WantedConstraints+-- Returns unsolved constraints, mostly just flat ones (Cts),+-- but also any unsolved implications arising from forall-constraints+-- The result is not necessarily zonked+solveSimpleWanteds simples+  = do { mode   <- getTcSMode+       ; dflags <- getDynFlags+       ; inerts <- getInertSet++       ; traceTcS "solveSimpleWanteds {" $+         vcat [ text "Mode:" <+> ppr mode+              , text "Inerts:" <+> ppr inerts+              , text "Wanteds to solve:" <+> ppr simples ]++       ; (n,simples',implics') <- go (solverIterations dflags) 1 emptyBag simples++       ; let unsolved_wc = emptyWC { wc_simple = simples', wc_impl = implics' }++       ; traceTcS "solveSimpleWanteds end }" $+             vcat [ text "iterations =" <+> ppr n+                  , text "residual =" <+> ppr unsolved_wc ]++       ; return unsolved_wc }+  where+    go :: IntWithInf       -- Limit+       -> Int              -- Iteration number+       -> Bag Implication  -- Accumulating parameter: unsolved implications+       -> Cts              -- Try to solve these+       -> TcS (Int, Cts, Bag Implication)+    -- See Note [The solveSimpleWanteds loop]+    go limit n implics wanted+      | n `intGtLimit` limit+      = failTcS $ TcRnSimplifierTooManyIterations+                         simples limit+                         (emptyWC { wc_simple = wanted, wc_impl = implics })++      | isEmptyBag wanted+      = return (n, wanted, implics)++      | otherwise+      = do { -- Solve+             (wanted1, implics1) <- solve_one wanted+           ; let implics2 = implics `unionBags` implics1++             -- Run plugins+             -- NB: runTcPluginsWanted has a fast path for+             --     empty wanted1, which is the common case+           ; (rerun_plugin, wanted2) <- runTcPluginsWanted wanted1++           ; if rerun_plugin+             then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin)+                     ; go limit (n+1) implics2 wanted2 }   -- Loop+             else return (n, wanted2, implics2) }          -- Done+++    solve_one :: Cts -> TcS (Cts, Bag Implication)+    -- Try solving these constraints+    -- Affects the unification state (of course) but not the inert set+    -- The result is not necessarily zonked+    solve_one simples+      = nestTcS $+        do { solveSimples simples+           ; simples' <- getUnsolvedInerts+               -- Now try to solve any Wanted quantified+               -- constraints (i.e. QCInsts) in `simples1`+           ; solveWantedQCIs simples' }+++{- Note [The solveSimpleWanteds loop]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Solving a bunch of simple constraints is done in a loop,+(the 'go' loop of 'solveSimpleWanteds'):+  1. Try to solve them+  2. Try the plugin+  3. If the plugin wants to run again, go back to step 1+-}++{-+************************************************************************+*                                                                      *+           Solving flat constraints: solveSimples+*                                                                      *+********************************************************************* -}++-- The main solver loop implements Note [Basic Simplifier Plan]+---------------------------------------------------------------++solveSimples :: Cts -> TcS ()+-- Solve this bag of constraints,+-- returning the final InertSet in TcS+-- The constraints are initially examined in left-to-right order++solveSimples cts+  = {-# SCC "solveSimples" #-}+    do { emitWork cts; solve_loop }+  where+    solve_loop+      = {-# SCC "solve_loop" #-}+        do { sel <- selectNextWorkItem+           ; case sel of+              Nothing -> return ()+              Just ct -> do { solveOne ct+                            ; solve_loop } }++solveOne :: Ct -> TcS ()  -- Solve one constraint+solveOne workItem+  = do { wl      <- getWorkList+       ; inerts  <- getInertSet+       ; tclevel <- TcS.getTcLevel+       ; traceTcS "----------------------------- " empty+       ; traceTcS "Start solver pipeline {" $+                  vcat [ text "tclevel =" <+> ppr tclevel+                       , text "work item =" <+> ppr workItem+                       , text "inerts =" <+> ppr inerts+                       , text "rest of worklist =" <+> ppr wl ]++       ; bumpStepCountTcS    -- One step for each constraint processed+       ; solve workItem }+  where+    solve :: Ct -> TcS ()+    solve ct+      = do { traceTcS "solve {" (text "workitem = " <+> ppr ct)+           ; res <- runSolverStage (solveCt ct)+           ; traceTcS "end solve }" (ppr res)+           ; case res of+               StartAgain ct -> do { traceTcS "Go round again" (ppr ct)+                                   ; solve ct }++               Stop ev s -> do { traceFireTcS ev s+                               ; traceTcS "End solver pipeline }" empty+                               ; return () }++               -- ContinueWith can't happen: res :: SolverStage Void+               -- solveCt either solves the constraint, or puts+               -- the unsolved constraint in the inert set.+            }++{- *********************************************************************+*                                                                      *+*              Solving one constraint: solveCt+*                                                                      *+************************************************************************++Note [Canonicalization]+~~~~~~~~~~~~~~~~~~~~~~~+Canonicalization converts a simple constraint to a canonical form. It is+unary (i.e. treats individual constraints one at a time).++Constraints originating from user-written code come into being as+CNonCanonicals. We know nothing about these constraints. So, first:++     Classify CNonCanoncal constraints, depending on whether they+     are equalities, class predicates, or other.++Then proceed depending on the shape of the constraint. Generally speaking,+each constraint gets rewritten and then decomposed into one of several forms+(see type Ct in GHC.Tc.Types).++When an already-canonicalized constraint gets kicked out of the inert set,+it must be recanonicalized. But we know a bit about its shape from the+last time through, so we can skip the classification step.+-}++solveCt :: Ct -> SolverStage Void+-- The Void result tells us that solveCt cannot return+-- a ContinueWith; it must return Stop or StartAgain.+solveCt (CNonCanonical ev)                   = solveNC ev+solveCt (CIrredCan (IrredCt { ir_ev = ev })) = solveNC ev++solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel+                      , eq_lhs = lhs, eq_rhs = rhs }))+  = solveEquality ev eq_rel (canEqLHSType lhs) rhs++solveCt (CQuantCan qci@(QCI { qci_ev = ev }))+  = do { ev' <- rewriteEvidence ev+         -- It is (much) easier to rewrite and re-classify than to+         -- rewrite the pieces and build a Reduction that will rewrite+         -- the whole constraint+       ; case classifyPredType (ctEvPred ev') of+           ForAllPred tvs theta body_pred+             -> solveForAll (qci { qci_ev = ev', qci_tvs = tvs+                                 , qci_theta = theta, qci_body = body_pred })+           _ -> pprPanic "SolveCt" (ppr ev) }++solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc }))+  = do { ev <- rewriteEvidence ev+         -- It is easier to rewrite and re-classify than to rewrite+         -- the pieces and build a Reduction that will rewrite the+         -- whole constraint+       ; case classifyPredType (ctEvPred ev) of+           ClassPred cls tys+             -> solveDict (DictCt { di_ev = ev, di_cls = cls+                                  , di_tys = tys, di_pend_sc = pend_sc })+           _ -> pprPanic "solveCt" (ppr ev) }++------------------+solveNC :: CtEvidence -> SolverStage Void+solveNC ev+  = -- Instead of rewriting the evidence before classifying, it's possible we+    -- can make progress without the rewrite. Try this first.+    -- For insolubles (all of which are equalities), do /not/ rewrite the arguments+    -- In #14350 doing so led entire-unnecessary and ridiculously large+    -- type function expansion.  Instead, canEqNC just applies+    -- the substitution to the predicate, and may do decomposition;+    --    e.g. a ~ [a], where [G] a ~ [Int], can decompose+    case classifyPredType (ctEvPred ev) of {+        EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 ;+        _ ->++    -- Do rewriting on the constraint, especially zonking+    do { ev <- rewriteEvidence ev++    -- And then re-classify+       ; case classifyPredType (ctEvPred ev) of+           ClassPred cls tys     -> solveDictNC ev cls tys+           ForAllPred tvs th p   -> solveForAllNC ev tvs th p+           IrredPred {}          -> solveIrred (IrredCt { ir_ev = ev, ir_reason = IrredShapeReason })+           EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2+              -- EqPred only happens if (say) `c` is unified with `a ~# b`,+              -- but that is rare because it requires c :: CONSTRAINT UnliftedRep++    }}+++{- *********************************************************************+*                                                                      *+*                      Quantified constraints+*                                                                      *+********************************************************************* -}++{- Note [Quantified constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The -XQuantifiedConstraints extension allows type-class contexts like this:++  data Rose f x = Rose x (f (Rose f x))++  instance (Eq a, forall b. Eq b => Eq (f b))+        => Eq (Rose f a)  where+    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2++Note the (forall b. Eq b => Eq (f b)) in the instance contexts.+This quantified constraint is needed to solve the+ [W] (Eq (f (Rose f x)))+constraint which arises form the (==) definition.++The wiki page is+  https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints+which in turn contains a link to the GHC Proposal where the change+is specified, and a Haskell Symposium paper about it.++We implement two main extensions to the design in the paper:++ 1. We allow a variable in the instance head, e.g.+      f :: forall m a. (forall b. m b) => D (m a)+    Notice the 'm' in the head of the quantified constraint, not+    a class.++ 2. We support superclasses to quantified constraints.+    For example (contrived):+      f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool+      f x y = x==y+    Here we need (Eq (m a)); but the quantified constraint deals only+    with Ord.  But we can make it work by using its superclass.++Here are the moving parts+  * Language extension {-# LANGUAGE QuantifiedConstraints #-}+    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension++  * A new form of evidence, EvDFun, that is used to discharge+    such wanted constraints++  * checkValidType gets some changes to accept forall-constraints+    only in the right places.++  * Predicate.Pred gets a new constructor ForAllPred, and+    and `classifyPredType` analyses a `PredType` to decompose+    the new forall-constraints++  * GHC.Tc.Solver.Monad.InertCans gets an extra field, `inert_qcis`,+    which holds all the Given forall-constraints.  In effect,+    such Given constraints are like local instance decls.++  * `inert_qcis` also temporarily holds Wanted quantified constraints+    (see Note [Solving a Wanted forall-constraint])++  * When trying to solve a class constraint, GHC.Tc.Solver.Dict.matchLocalInst+    (note "local" inst) uses the Given `inert_qcis` to solve the constraint.++  * `solveForAll` deals with solving a forall-constraint.  See+       * Note [Solving a Given forall-constraint]+       * Note [Solving a Wanted forall-constraint]++Note that a quantified constraint is never /inferred/+(by GHC.Tc.Solver.simplifyInfer).  A function can only have a+quantified constraint in its type if it is given an explicit+type signature.++Note [Solving a Given forall-constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a Given constraint+  [G] df :: forall ab. (Eq a, Ord b) => C x a b+we just add it to TcS's local InstEnv of known instances, `inert_qcis`,+via addInertQCI.  Then, if we look up (C x Int Bool), say,+we'll find a match in the `inert_qcis`.++Note [Solving a Wanted forall-constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Solving a wanted forall (quantified) constraint+  [W] df :: forall a b. (Eq a, Ord b) => C x a b+is delightfully easy in principle.   Just build an implication constraint+    forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a+and discharge df thus:+    df = /\ab. \g1 g2. let <binds> in d+where <binds> is filled in by solving the implication constraint.++What we actually do is this:++* In `solveForAll` we see if we have an identical quantified constraint+  to solve it (using tryInertQCs).  In particular, solve a Wanted QCI+  from an identical Given.  This is more than a simple optimisation:+  see Note [Solving Wanted QCs from Given QCs]++  If not, just stash it in `inert_qcis :: [QCInst]`. (If it's a Given+  we can use it to solve other constraints; if a Wanted we will solve+  it later using `solveWantedQCIs`.)++* In the main `solveSimpleWanteds` (specifically `solve_one`):++  - We attempt to solve the `wc_simple` constraints with `solveSimples`+    Unsolved quantified constraints just accumulate in the `inert_qcis` field+    of the `InertSet`.++  - Then we use `solveWantedQCIs` to solve any quantified constraints. That+    often turns the `QCInst` into an `Implication`; but not invariably (WFA4)++Wrinkles:++(WFA2) Termination: see #19690.  We want to maintain the invariant (QC-INV):++    (QC-INV) Every quantified constraint returns a non-bottom dictionary++  just as every top-level instance declaration guarantees to return a non-bottom+  dictionary.  But as #19690 shows, it is possible to get a bottom dictionary+  by superclass selection if we aren't careful.  The situation is very similar+  to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance;+  and we use the same solution:++  * Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size))+  * Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc)++  Both of these things are done in `solveWantedQCI`.  Now the mechanism described+  in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over.++(WFA3) Error messages. Suppose we are trying to solve the quantified constraint+            forall a. Eq a => Eq (c a)+  We don't just want to say "No instance for Eq (c a)".  It /really/ helps to+  say what quantified constraint we were trying to solve.++  So the `IsQC` origin carries that info, and `GHC.Tc.Errors.Ppr.pprQCOriginExtra`+  prints the extra info.++(WFA4) When `tcsmFullySolveQCIs` is on, we adopt an all-or-nothing strategy:+   either solve the forall-constraint /fully/ or do nothing at all.+   Why?  See (NFS1) in Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig++(WFA5) Why not /always/ us the all-or-nothing strategy, so we don't need a+  flag?  Several reasons:++  * Less efficient; `tcsmFullySolveQCIs` abandons the work done on the constraint,+    so we might do it again next time around.++  * More importantly, we would get worse results from `deriving`: #26315.+    In that code the `deriving` mechanism was trying to solve+           [W] df :: forall n. Eq (Const i n)+    If we turn it into an implication, we can simplfy that `Const` to get+    the residual implication+           forall n.  [W] d :: Eq i+    And then `approximateWC` can extract the (Eq i) as a plausible context for+    the instance.++  * Very much the same issue came up for the inferred type of a function that+    lacks a type signature #26376.  Again, if the forall-constraint is not+    turned into an implication `approximateWC` gives a less-good answer.++Note [Solving Wanted QCs from Given QCs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are about to solve a Wanted quantified constraint, and there is a+Given quantified constraint with the same type, we should directly solve the+Wanted from the Given (instead of building an implication).++Not only is this more direct and efficient, sometimes it is also /necessary/.+Consider:++  f :: forall a k. (Eq a, forall x. Eq x => Eq k x) => a -> blah+  {-# SPECIALISE (f :: forall k. (forall x. Eq x => Eq k x) => Int -> blah #-}++Here we specialise the `a` parameter to `f`, leaving the quantified constraint+untouched.  We want to get a rule like:++  RULE  forall @k (d :: forall x. Eq x => Eq k x).+            f @Int @k d = $sf @k d++But when we typecheck that expression-with-a-type-signature, if we don't solve+Wanted forall constraints directly, we will do so indirectly and end up with+this as the LHS of the RULE:++  (/\k \(df::forall x.Eq x => Eq k x). f @Int @k (/\x \(d:Eq x). df @x d))+     @kk dd++We run the simple optimiser on that, which eliminates the beta-redex. However,+it may not eta-reduce that `/\x \(d:Eq x)...`, because we are cautious about+eta-reduction. So we may be left with an over-complicated and hard-to-match+RULE LHS. It's all a bit silly, because the implication constraint is /identical/;+we just need to spot it.++This came up while implementing GHC proposal 493 (allowing expresions in+SPECIALISE pragmas).+-}++-- | Solve a quantified constraint that came from @CNonCanonical@ (which means+-- that superclasses have not yet been expanded).+--+-- Precondition: the constraint has already been rewritten by the inert set.+solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType+              -> SolverStage Void+solveForAllNC ev tvs theta body_pred+  = do { fuel <- simpleStage mk_super_classes+       ; solveForAll (QCI { qci_ev = ev, qci_tvs = tvs, qci_theta = theta+                          , qci_body = body_pred, qci_pend_sc = fuel }) }++  where+    mk_super_classes :: TcS ExpansionFuel+    mk_super_classes+       | Just (cls,tys) <- getClassPredTys_maybe body_pred+       , classHasSCs cls+       = do { dflags <- getDynFlags+            -- Either expand superclasses (Givens) or provide fuel to do so (Wanteds)+            ; if isGiven ev+              then+                -- See Note [Eagerly expand given superclasses]+                -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]+                do { sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys+                   ; emitWork (listToBag sc_cts)+                   ; return doNotExpand }+              else+                -- See invariants (a) and (b) in QCI.qci_pend_sc+                -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]+                -- See Note [Quantified constraints]+                return (qcsFuel dflags)+            }++       | otherwise+       = return doNotExpand++-- | Solve a canonical quantified constraint.+--+-- Precondition: the constraint has already been rewritten by the inert set.+solveForAll :: QCInst -> SolverStage Void+solveForAll qci@(QCI { qci_ev = ev })+  = case ev of+      CtGiven {} ->+        -- See Note [Solving a Given forall-constraint]+        do { simpleStage (addInertQCI qci)+           ; stopWithStage ev "Given forall-constraint" }+      CtWanted {} ->+        -- See Note [Solving a Wanted forall-constraint]+        do { tryInertQCs qci+           ; simpleStage (addInertQCI qci)+           ; stopWithStage ev "Wanted forall-constraint" }++tryInertQCs :: QCInst -> SolverStage ()+tryInertQCs qc+  = Stage $+    do { inerts <- getInertCans+       ; try_inert_qcs qc (inert_qcis inerts) }++try_inert_qcs :: QCInst -> [QCInst] -> TcS (StopOrContinue ())+try_inert_qcs (QCI { qci_ev = ev_w }) inerts =+  case mapMaybe matching_inert inerts of+    [] -> do { traceTcS "tryInertQCs:nothing" (ppr ev_w $$ ppr inerts)+             ; continueWith () }+    ev_i:_ ->+      do { traceTcS "tryInertQCs:KeepInert" (ppr ev_i)+         ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i)+         ; stopWith ev_w "Solved Wanted forall-constraint from inert" }+  where+    matching_inert (QCI { qci_ev = ev_i })+      | ctEvPred ev_i `tcEqType` ctEvPred ev_w+      = Just ev_i+      | otherwise+      = Nothing++solveWantedQCIs :: Cts -> TcS (Cts, Bag Implication)+solveWantedQCIs wanteds+  = do { mode <- getTcSMode+       ; bag_of_eithers <- mapBagM (solveWantedQCI mode) wanteds+         -- bag_of_eithers :: Bag (Either Ct Implication)+       ; return (partitionBagWith id bag_of_eithers) }++solveWantedQCI :: TcSMode+               -> Ct   -- Definitely a Wanted+               -> TcS (Either Ct Implication)+-- Try to solve a quantified constraint, `ct`+-- Returns+--    (Left ct) if `ct` is not a quantified constraint+--    (Right implic) if we can solve a quantified constraint `ct` by creating+--                   an implication and fully or partly solving it+--    (Left ct) for a quantified constraint that can't be /fully solved/,+--              but mode is tcsmFullySolveQCIs+-- See Note [Solving a Wanted forall-constraint]+solveWantedQCI mode ct@(CQuantCan (QCI { qci_ev =  ev, qci_tvs = tvs+                                       , qci_theta = theta, qci_body = body_pred }))+  | CtWanted (WantedCt { ctev_pred = forall_pred, ctev_dest = dest+                       , ctev_rewriters = rewriters, ctev_loc = loc }) <- ev+  , let is_qc = IsQC forall_pred (ctLocOrigin loc)+        empty_subst = mkEmptySubst $ mkInScopeSet $+                      tyCoVarsOfTypes (body_pred:theta) `delVarSetList` tvs+  = TcS.setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $+    -- This setSrcSpan is important: the TcM.newImplication uses that+    -- TcLclEnv for the implication, and that in turn sets the location+    -- for the Givens when solving the constraint (#21006)+    do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]+         --           in GHC.Tc.Utils.TcType+         -- Very like the code in tcSkolDFunType+       ; rec { skol_info <- mkSkolemInfo skol_info_anon+             ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs+             ; let inst_pred  = substTy    subst body_pred+                   inst_theta = substTheta subst theta+                   skol_info_anon = InstSkol is_qc (pSizeHead inst_pred) }++       ; given_ev_vars <- mapM TcS.newEvVar inst_theta+       ; (lvl, wanted_ev)+             <- pushLevelNoWorkList (ppr skol_info) $+                do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc)+                         -- Set the thing to prove to have a ScOrigin, so we are+                         -- careful about its termination checks.+                         -- See (QC-INV) in Note [Solving a Wanted forall-constraint]+                   ; newWantedNC loc' rewriters inst_pred }++       ; ev_binds_var <- TcS.newTcEvBinds+       ; let imp :: Implication+             imp = (implicationPrototype (ctLocEnv loc))+                     { ic_tclvl  = lvl+                     , ic_skols  = skol_tvs+                     , ic_given  = given_ev_vars+                     , ic_wanted = mkSimpleWC [CtWanted wanted_ev]+                     , ic_binds  = ev_binds_var+                     , ic_warn_inaccessible = False+                     , ic_info   = skol_info_anon }++      ; imp' <- solveImplication imp+++      ; if | tcsmFullySolveQCIs mode+           , not (isSolvedStatus (ic_status imp'))+           -> -- Not fully solved, but mode says that we must fully+              -- solve quantified constraints; so abandon the attempt+              -- See (WFA4) in Note [Solving a Wanted forall-constraint]+              return (Left ct)++           | otherwise+           -> -- Commit to the (partly or fully solved) implication+              -- See (WFA5) in Note [Solving a Wanted forall-constraint]+              -- Record evidence and return residual implication+              -- NB: even if it is fully solved we must return it, because it is+              --     carrying a record of which evidence variables are used+              --     See Note [Free vars of EvFun] in GHC.Tc.Types.Evidence+             do { setWantedEvTerm dest EvCanonical $+                  EvFun { et_tvs = skol_tvs, et_given = given_ev_vars+                        , et_binds = TcEvBinds ev_binds_var+                        , et_body = wantedCtEvEvId wanted_ev }++                ; return (Right imp') }+    }++  | otherwise  -- A Given QCInst+  = pprPanic "wantedQciToImplic: found a Given QCI" (ppr ct)++-- No-op on all Ct's other than CQuantCan+solveWantedQCI _ ct = return (Left ct)+++{-+************************************************************************+*                                                                      *+                  Evidence transformation+*                                                                      *+************************************************************************+-}++rewriteEvidence :: CtEvidence -> SolverStage CtEvidence+-- (rewriteEvidence old_ev new_pred co do_next)+-- Main purpose: create new evidence for new_pred;+--                 unless new_pred is cached already+-- * Calls do_next with (new_ev :: new_pred), with same wanted/given flag as old_ev+-- * If old_ev was wanted, create a binding for old_ev, in terms of new_ev+-- * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev+-- * Stops if new_ev is already cached+--+--        Old evidence    New predicate is               Return new evidence+--        flavour                                        of same flavor+--        -------------------------------------------------------------------+--        Wanted          Already solved or in inert     Stop+--                        Not                            do_next new_evidence+--+--        Given           Already in inert               Stop+--                        Not                            do_next new_evidence++{- Note [Rewriting with Refl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the coercion is just reflexivity then you may re-use the same+evidence variable.  But be careful!  Although the coercion is Refl, new_pred+may reflect the result of unification alpha := ty, so new_pred might+not _look_ the same as old_pred, and it's vital to proceed from now on+using new_pred.++The rewriter preserves type synonyms, so they should appear in new_pred+as well as in old_pred; that is important for good error messages.++If we are rewriting with Refl, then there are no new rewriters to add to+the rewriter set. We check this with an assertion.+ -}+++rewriteEvidence ev+  = Stage $ do { traceTcS "rewriteEvidence" (ppr ev)+               ; (redn, rewriters) <- rewrite ev (ctEvPred ev)+               ; finish_rewrite ev redn rewriters }++finish_rewrite :: CtEvidence   -- ^ old evidence+               -> Reduction    -- ^ new predicate + coercion, of type <type of old evidence> ~ new predicate+               -> RewriterSet  -- ^ See Note [Wanteds rewrite Wanteds]+                               -- in GHC.Tc.Types.Constraint+               -> TcS (StopOrContinue CtEvidence)+finish_rewrite old_ev (Reduction co new_pred) rewriters+  | isReflCo co -- See Note [Rewriting with Refl]+  = assert (isEmptyRewriterSet rewriters) $+    continueWith (setCtEvPredType old_ev new_pred)++finish_rewrite+  ev@(CtGiven (GivenCt { ctev_evar = old_evar }))+  (Reduction co new_pred)+  rewriters+  = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted+    do { let loc = ctEvLoc ev+             -- mkEvCast optimises ReflCo+             ev_rw_role = ctEvRewriteRole ev+             new_tm = assert (coercionRole co == ev_rw_role)+                      evCast (evId old_evar) $   -- evCast optimises ReflCo+                      downgradeRole Representational ev_rw_role co+       ; new_ev <- newGivenEvVar loc (new_pred, new_tm)+       ; continueWith $ CtGiven new_ev }++finish_rewrite+  ev@(CtWanted (WantedCt { ctev_rewriters = rewriters, ctev_dest = dest }))+  (Reduction co new_pred)+  new_rewriters+  = do { let loc = ctEvLoc ev+             rewriters' = rewriters S.<> new_rewriters+             ev_rw_role = ctEvRewriteRole ev+       ; mb_new_ev <- newWanted loc rewriters' new_pred+       ; massert (coercionRole co == ev_rw_role)+       ; setWantedEvTerm dest EvCanonical $+         evCast (getEvExpr mb_new_ev)     $+         downgradeRole Representational ev_rw_role (mkSymCo co)+       ; case mb_new_ev of+            Fresh  new_ev -> continueWith $ CtWanted new_ev+            Cached _      -> stopWith ev "Cached wanted" }++{- *******************************************************************+*                                                                    *+*                      Typechecker plugins+*                                                                    *+******************************************************************* -}++-- | Extract the (inert) givens and invoke the plugins on them.+-- Remove solved givens from the inert set and emit insolubles, but+-- return new work produced so that 'solveSimpleGivens' can feed it back+-- into the main solver.+runTcPluginsGiven :: TcS [Ct]+runTcPluginsGiven+  = do { solvers <- getTcPluginSolvers+       ; if null solvers then return [] else+    do { givens <- getInertGivens+       ; if null givens then return [] else+    do { traceTcS "runTcPluginsGiven {" (ppr givens)+       ; p <- runTcPluginSolvers solvers (givens,[])+       ; let (solved_givens, _) = pluginSolvedCts p+             insols             = map (ctIrredCt PluginReason) (pluginBadCts p)+       ; updInertCans (removeInertCts solved_givens .+                       updIrreds (addIrreds insols) )+       ; traceTcS "runTcPluginsGiven }" $+         vcat [ text "solved_givens:" <+> ppr solved_givens+              , text "insols:" <+> ppr insols+              , text "new:" <+> ppr (pluginNewCts p) ]+       ; return (pluginNewCts p) } } }++-- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on+-- them and produce an updated bag of wanteds (possibly with some new+-- work) and a bag of insolubles.  The boolean indicates whether+-- 'solveSimpleWanteds' should feed the updated wanteds back into the+-- main solver.+runTcPluginsWanted :: Cts -> TcS (Bool, Cts)+runTcPluginsWanted wanted+  | isEmptyBag wanted+  = return (False, wanted)+  | otherwise+  = do { solvers <- getTcPluginSolvers+       ; if null solvers then return (False, wanted) else++    do { -- Find the set of Givens to give to the plugin.+         given <- getInertGivens++         -- Plugin requires zonked input wanteds+       ; zonked_wanted <- TcS.zonkSimples wanted++       ; traceTcS "Running plugins {" (vcat [ text "Given:" <+> ppr given+                                            , text "Wanted:" <+> ppr zonked_wanted ])+       ; p <- runTcPluginSolvers solvers (given, bagToList zonked_wanted)+       ; let (_, solved_wanted)   = pluginSolvedCts p+             (_, unsolved_wanted) = pluginInputCts p+             new_wanted     = pluginNewCts p+             insols         = pluginBadCts p+             all_new_wanted = listToBag new_wanted       `andCts`+                              listToBag unsolved_wanted  `andCts`+                              listToBag insols++       ; mapM_ setEv solved_wanted++       ; traceTcS "Finished plugins }" (ppr new_wanted)+       ; return ( notNull (pluginNewCts p), all_new_wanted ) } }+  where+    setEv :: (EvTerm,Ct) -> TcS ()+    setEv (ev,ct) = case ctEvidence ct of+      CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest EvCanonical ev+           -- TODO: plugins should be able to signal non-canonicity+      _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"++-- | A pair of (given, wanted) constraints to pass to plugins+type SplitCts  = ([Ct], [Ct])++-- | A solved pair of constraints, with evidence for wanteds+type SolvedCts = ([Ct], [(EvTerm,Ct)])++-- | Represents collections of constraints generated by typechecker+-- plugins+data TcPluginProgress = TcPluginProgress+    { pluginInputCts  :: SplitCts+      -- ^ Original inputs to the plugins with solved/bad constraints+      -- removed, but otherwise unmodified+    , pluginSolvedCts :: SolvedCts+      -- ^ Constraints solved by plugins+    , pluginBadCts    :: [Ct]+      -- ^ Constraints reported as insoluble by plugins+    , pluginNewCts    :: [Ct]+      -- ^ New constraints emitted by plugins+    }++getTcPluginSolvers :: TcS [TcPluginSolver]+getTcPluginSolvers+  = do { tcg_env <- TcS.getGblEnv; return (tcg_tc_plugin_solvers tcg_env) }++-- | Starting from a pair of (given, wanted) constraints,+-- invoke each of the typechecker constraint-solving plugins in turn and return+--+--  * the remaining unmodified constraints,+--  * constraints that have been solved,+--  * constraints that are insoluble, and+--  * new work.+--+-- Note that new work generated by one plugin will not be seen by+-- other plugins on this pass (but the main constraint solver will be+-- re-invoked and they will see it later).  There is no check that new+-- work differs from the original constraints supplied to the plugin:+-- the plugin itself should perform this check if necessary.+runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress+runTcPluginSolvers solvers all_cts+  = do { ev_binds_var <- getTcEvBindsVar+       ; foldM (do_plugin ev_binds_var) initialProgress solvers }+  where+    do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress+    do_plugin ev_binds_var p solver = do+        result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p))+        return $ progress p result++    progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress+    progress p+      (TcPluginSolveResult+        { tcPluginInsolubleCts = bad_cts+        , tcPluginSolvedCts    = solved_cts+        , tcPluginNewCts       = new_cts+        }+      ) =+        p { pluginInputCts  = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p)+          , pluginSolvedCts = add solved_cts (pluginSolvedCts p)+          , pluginNewCts    = new_cts ++ pluginNewCts p+          , pluginBadCts    = bad_cts ++ pluginBadCts p+          }++    initialProgress = TcPluginProgress all_cts ([], []) [] []++    discard :: [Ct] -> SplitCts -> SplitCts+    discard cts (xs, ys) =+        (xs `without` cts, ys `without` cts)++    without :: [Ct] -> [Ct] -> [Ct]+    without = deleteFirstsBy eq_ct++    eq_ct :: Ct -> Ct -> Bool+    eq_ct c c' = ctFlavour c == ctFlavour c'+              && ctPred c `tcEqType` ctPred c'++    add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts+    add xs scs = foldl' addOne scs xs++    addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts+    addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of+      CtGiven  {} -> (ct:givens, wanteds)+      CtWanted {} -> (givens, (ev,ct):wanteds)
+ compiler/GHC/Tc/Solver/Solve.hs-boot view
@@ -0,0 +1,8 @@+module GHC.Tc.Solver.Solve where++import Prelude( Bool )+import GHC.Tc.Solver.Monad( TcS )+import GHC.Tc.Types.Constraint( Cts, Implication, WantedConstraints )++solveSimpleWanteds :: Cts -> TcS WantedConstraints+trySolveImplication :: Implication -> TcS Bool
compiler/GHC/Tc/TyCl.hs view
@@ -10,8 +10,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Typecheck type and class declarations module GHC.Tc.TyCl (         tcTyAndClassDecls,@@ -21,9 +19,12 @@         kcConDecls, tcConDecls, DataDeclInfo(..),         dataDeclChecks, checkValidTyCon,         tcFamTyPats, tcTyFamInstEqn,-        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,+        tcAddOpenTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,         unravelFamInstPats, addConsistencyConstraints,-        checkFamTelescope+        checkFamTelescope,++        -- Used by GHC.HsToCore.Quote+        IsPrefixConGADT(..), unannotatedMultIsLinear     ) where  import GHC.Prelude@@ -55,10 +56,11 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Instance.Family-import GHC.Tc.Types.Origin+import GHC.Tc.Types.ErrCtxt ( TyConInstFlavour(..) ) import GHC.Tc.Types.LclEnv+import GHC.Tc.Types.Origin -import GHC.Builtin.Types (oneDataConTy,  unitTy, makeRecoveryTyCon )+import GHC.Builtin.Types ( oneDataConTy,  unitTy, makeRecoveryTyCon, manyDataConTy )  import GHC.Rename.Env( lookupConstructorFields ) @@ -74,7 +76,6 @@ import GHC.Core.DataCon import GHC.Core.Unify -import GHC.Types.Error import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Var@@ -88,11 +89,13 @@ import GHC.Types.TypeEnv import GHC.Types.Unique import GHC.Types.Basic+import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt  import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.List.SetOps( minusList, equivClasses )+import GHC.Data.OrdList  import GHC.Unit import GHC.Unit.Module.ModDetails@@ -112,6 +115,7 @@ import qualified Data.List.NonEmpty as NE import Data.Traversable ( for ) import Data.Tuple( swap )+import qualified Data.Semigroup as S  {- ************************************************************************@@ -147,44 +151,379 @@ *all* the tycons in a group for validity before checking *any* of the roles. Thus, we take two passes over the resulting tycons, first checking for general validity and then checking for valid role annotations.++Note [Retrying TyClGroups]+~~~~~~~~~~~~~~~~~~~~~~~~~~+After renaming type, class, and instance declarations in a module (or, to be+more precise, in an HsGroup), GHC.Rename.Module.rnTyClDecls does dependency+analysis on the renamed declarations and returns a topologically sorted list+of SCCs, each SCC represented by one TyClGroup.++If the dependency analysis were complete, i.e. if it were able to discover all+dependencies between all declarations, then tcTyAndClassDecls could simply+kind-check TyClGroups in order. Unfortunately, this is not the case, because+dependencies come in two varieties:++* Lexical dependencies arise when X mentions Y by name:++    data X (a :: Y) = MkX   -- depends on Y+    data Y = MkY++* Non-lexical dependencies arise when an instance must be in the+  typing environment:++    type family F x+    data X (a :: F Int) = MkX a   -- depends on (F Int ~ Type)+    type instance F x = Type++Non-lexical dependencies can't be discovered by looking at the free variables of+a declaration (attempts to find a good heuristic did not bear fruit, see the+long discussion at #12088 and the linked Wiki pages). As a consequence, the+order of SCCs (i.e. TyClGroups) coming out of the renamer is determined solely+by lexical dependencies.++In other words, the TyClGroups are in /lexical dependency order/, meaning:+- definitely in dependency order if all dependencies are lexical+- possibly not in dependency order if there are non-lexical dependencies++Here are some examples how type checking declarations might go wrong due to+non-lexical dependencies:++* Consider (#11348)++    type family F a+    type instance F Int = Bool++    data R = MkR (F Int)++    type Foo = 'MkR 'True++  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't+  know that unless we've looked at the type instance declaration for F+  before kind-checking Foo.++* Things become more complicated when we introduce transitive+  dependencies through imported definitions, like in this scenario:++      A.hs+        type family Closed (t :: Type) :: Type where+          Closed t = Open t++        type family Open (t :: Type) :: Type++      B.hs+        data Q where+          Q :: Closed Bool -> Q++        type instance Open Int = Bool++        type S = 'Q 'True++  Somehow, we must ensure that the instance Open Int = Bool is checked before+  the type synonym S. While we know that S depends upon 'Q depends upon Closed,+  we have no idea that Closed depends upon Open!++* Another example is this (#3990).++    data family Complex a+    data instance Complex Double = CD {-# UNPACK #-} !Double+                                      {-# UNPACK #-} !Double++    data T = T {-# UNPACK #-} !(Complex Double)++  Here, to generate the right kind of unpacked implementation for T,+  we must have access to the 'data instance' declaration.++To accommodate for these situations, tcTyAndClassDecls discovers the correct+kind-checking order by trial and error.++The algorithm works as follows:++1. (in rnTyClDecls)+   Perform the SCC analysis on declarations without instances and considering+   lexical dependencies only. The result is a topologically sorted list of SCCs.+   See Note [Dependency analysis of type and class decls] in GHC.Rename.Module++2. (in rnTyClDecls)+   Create one singleton "SCC" per instance and put them at the end.+   See Note [Put instances at the end] in GHC.Rename.Module++3. (in tcTyAndClassDecls)+   Check all SCCs in order, skipping any that are blocked (FVs not in env),+   flawed (unusable unpack pragmas), or fail (type errors)+   (3a) if none were skipped, we are done+   (3b) if all were skipped and none are flawed, we are stuck;+        report errors and exit (tcFailedTyClGroups)+   (3c) if all were skipped and some are flawed, redo the pass+        allowing flawed SCCs (tcTyClGroupsPass.go with strict=False)+   (3d) if some were skipped and some weren't, we've made progress; iterate++In the common case of lexical dependencies only, the algorithm is linear in the+number of groups: it completes in one pass if the program is kind-correct, or+two passes if there are kind errors.++In the less common case of non-lexical dependencies, the algorithm is worst-case+quadratic in the number of groups: if each pass manages to check only one group,+we end up doing a pass per group.++Now, regarding the "flawed" groups. These are the ones where the programmer used+the {-# UNPACK #-} pragma on a field, yet we could not unpack (#3990)++* One possible reason for this is that we lack a data instance in the+  environment that would allow for the field to be unpacked, so it is beneficial+  to treat this like a kind error: skip the flawed group and retry it in a later+  pass, when we might have more data instances in the env.++* However, if the /only/ reason a pass gets stuck is due to flawed groups,+  then we can make progress by treating unpacking failure is a warning.++This way we maximize unpacking with explicit {-# UNPACK #-} pragmas.+Unfortunately, it does not help with -funbox-strict-fields.+See Note [Flaky -funbox-strict-fields with type/data families]++Later we might check TyClGroups for other "flaws", but for now the property is+just about unusable unpack pragmas.++Finally, a short comment on why it is necessary to check whether a group is+ready (FVs in the env) or blocked (FVs not in the env) using isReadyTyClGroup.+One might expect this check to be redundant, as the TyClGroups come in lexical+dependency order. However, as soon as we skip a group, the rest of the pass can+no longer rely on this property, hence the check. It is rare to encounter this+problem in a kind-correct program, but see e.g. the T12088e test case.++Note [Flaky -funbox-strict-fields with type/data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this program:++  {-# OPTIONS -funbox-strict-fields #-}+  data family Complex a+  data instance Complex Double = CD !Double !Double+  data T = T !(Complex Double)  -- does (Complex Double) get unpacked?++Could we unpack T's field (Complex Double)? This depends on whether we have the+data instance in the environment. Prior GHC versions could handle this example,+but it was not reliable. A slightly more involved arrangement could throw it off+balance:++  {-# OPTIONS -funbox-strict-fields #-}+  type family F a+  data D1 = MkD1 !(F Int)       -- does (F Int) get unpacked?+  data D2 = MkD2 !Int !Int+  type instance F Int = D2++Here, MkD1's field (F Int) would not get unpacked unless we used a top-level+splice to separate the module and force the desired order of kind-checking:++  {-# OPTIONS -funbox-strict-fields #-}+  type family F a+  data D2 = MkD2 !Int !Int+  type instance F Int = D2+  $(return [])                -- break the module into two sections+  data D1 = MkD1 !(F Int)     -- now (F Int) surely gets unpacked++The current version of GHC is more predictable. Neither the (Complex Double) nor+the (F Int) example gets unpacking unless the type/data instance is put into a+separate HsGroup, either with $(return []) or by placing it in another module+altogether. This is a direct result of placing instances after the other SCCs,+as described in Note [Put instances at the end] in GHC.Rename.Module++It is also possible to get the desired unpacking with an explicit {-# UNPACK #-}+pragma, as an unusable unpack pragma marks a TyClGroup "flawed", which means it+will be retried after more type/data instances are added to the typing+environment. See the algorithm in Note [Retrying TyClGroups]. -} -tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in-                                            -- dependency order-                  -> TcM ( TcGblEnv         -- Input env extended by types and-                                            -- classes-                                            -- and their implicit Ids,DataCons-                         , [InstInfo GhcRn] -- Source-code instance decls info-                         , [DerivInfo]      -- Deriving info-                         , ThBindEnv        -- TH binding levels-                         )+data TcTyClGroupsAccum =+  TcTyClGroupsAccum+    { ttcga_inst_info   :: !(OrdList (InstInfo GhcRn)) -- ^ Source-code instance decls info+    , ttcga_deriv_info  :: !(OrdList DerivInfo)        -- ^ Deriving info+    , ttcga_th_bndrs    :: !ThBindEnv                  -- ^ TH binding levels+    }++instance S.Semigroup TcTyClGroupsAccum where+  (TcTyClGroupsAccum a1 b1 c1) <> (TcTyClGroupsAccum a2 b2 c2) =+    TcTyClGroupsAccum (a1 S.<> a2)+                      (b1 S.<> b2)+                      (c1 S.<> c2)++instance Monoid TcTyClGroupsAccum where+  mempty = TcTyClGroupsAccum mempty mempty mempty++tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in lexical dependency order+  -> TcM ( TcGblEnv         -- Input env extended by types and classes and their implicit Ids, DataCons+         , [InstInfo GhcRn] -- Source-code instance decls info+         , [DerivInfo]      -- Deriving info+         , ThBindEnv        -- TH binding levels+         ) -- Fails if there are any errors tcTyAndClassDecls tyclds_s   -- The code recovers internally, but if anything gave rise to   -- an error we'd better stop now, to avoid a cascade   -- Type check each group in dependency order folding the global env-  = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s+  = checkNoErrs $ go mempty tyclds_s   where-    fold_env :: [InstInfo GhcRn]-             -> [DerivInfo]-             -> ThBindEnv-             -> [TyClGroup GhcRn]-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)-    fold_env inst_info deriv_info th_bndrs []-      = do { gbl_env <- getGblEnv-           ; return (gbl_env, inst_info, deriv_info, th_bndrs) }-    fold_env inst_info deriv_info th_bndrs (tyclds:tyclds_s)-      = do { (tcg_env, inst_info', deriv_info', th_bndrs')-               <- tcTyClGroup tyclds-           ; setGblEnv tcg_env $-               -- remaining groups are typechecked in the extended global env.-             fold_env (inst_info' ++ inst_info)-                      (deriv_info' ++ deriv_info)-                      (th_bndrs' `plusNameEnv` th_bndrs)-                      tyclds_s }+    go :: TcTyClGroupsAccum+       -> [TyClGroup GhcRn]+       -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)+    go acc [] = do  -- Case (3a) of the algorithm in Note [Retrying TyClGroups]+                    -- All good, we are done.+      tcg_env <- getGblEnv+      let inst_info  = fromOL (ttcga_inst_info acc)+          deriv_info = fromOL (ttcga_deriv_info acc)+          th_bndrs   = ttcga_th_bndrs acc+      return (tcg_env, inst_info, deriv_info, th_bndrs)+    go acc gs =+      tcTyClGroupsPass gs $ \acc' n gs' ->+        if n == 0 then+          -- Case (3b) of the algorithm in Note [Retrying TyClGroups]+          -- The pass made no progress. We are stuck. Report errors and exit.+          tcFailedTyClGroups gs'+        else+          -- Case (3b) of the algorithm in Note [Retrying TyClGroups]+          -- The pass made some progress. Iterate.+          go (acc' S.<> acc) gs' +-- Check the remaining TyClGroups that are known to fail,+-- extending the environment with fake tycons to report more errors.+-- See Note [Recover from validity error]+tcFailedTyClGroups :: [TyClGroup GhcRn] -> TcM a+tcFailedTyClGroups [] = failM+tcFailedTyClGroups (g:gs) = do+  tcg_env <- getGblEnv+  m_result <-+    if isReadyTyClGroup tcg_env g+    then attemptM (tcTyClGroup g)+    else return Nothing+  let tcg_env' = maybe tcg_env fst m_result+  setGblEnv tcg_env' $ tcFailedTyClGroups gs++-- Type check as many TyClGroups as possible, skipping any failures.+-- thing_inside runs in the extended environment.+tcTyClGroupsPass :: forall a.+     [TyClGroup GhcRn]     -- Mutually-recursive groups in lexical dependency order+  -> (TcTyClGroupsAccum+      -> Int               -- Number of successfully checked groups+      -> [TyClGroup GhcRn] -- Remaining groups in lexical dependency order+      -> TcM a)+  -> TcM a+tcTyClGroupsPass all_gs thing_inside = go True ttcgs_zero mempty nilOL all_gs+  where+    go :: Bool                -- Strict pass, True <=> fail on unusable {-# UNPACK #-}+       -> TcTyClGroupsStats+       -> TcTyClGroupsAccum+       -> OrdList (TyClGroup GhcRn)  -- Skipped groups (accumulator)+       -> [TyClGroup GhcRn]          -- Groups to check+       -> TcM a+    go strict !stats acc skipped_gs []+      | strict, ttcgs_n_success stats == 0, ttcgs_n_flawed stats > 0 = do+          -- Case (3b) of the algorithm in Note [Retrying TyClGroups]+          -- The strict pass made no progress but found flawed groups;+          -- now do a lax pass to allow them to succeed.+          traceTc "tcTyClGroupsPass end of strict pass" (ppr stats)+          go False ttcgs_zero acc nilOL (fromOL skipped_gs)+      | otherwise = do+          traceTc "tcTyClGroupsPass done" (ppr stats)+          thing_inside acc (ttcgs_n_success stats) (fromOL skipped_gs)+    go strict !stats acc skipped_gs (g:gs) = do+      (stats', m_result) <- try_tc_group strict stats (null skipped_gs) g+      case m_result of+        Nothing ->+          go strict stats' acc (skipped_gs `snocOL` g) gs+        Just (tcg_env, acc') ->+          setGblEnv tcg_env $+          go strict stats' (acc' S.<> acc) skipped_gs gs++    try_tc_group :: Bool   -- Strict pass, True <=> fail on unusable {-# UNPACK #-}+                 -> TcTyClGroupsStats+                 -> Bool   -- True <=> No groups skipped this pass (yet)+                 -> TyClGroup GhcRn+                 -> TcM (TcTyClGroupsStats, Maybe (TcGblEnv, TcTyClGroupsAccum))+    try_tc_group strict stats no_skipped g = do+      tcg_env <- getGblEnv+      let on_flawed    = (ttcgs_inc_flawed  stats, Nothing)+          on_failed    = (ttcgs_inc_failed  stats, Nothing)+          on_blocked   = (ttcgs_inc_blocked stats, Nothing)+          on_success r = (ttcgs_inc_success stats, Just r)+          ready = no_skipped || isReadyTyClGroup tcg_env g+              -- (no_skipped ||) is a shortcut: if no groups were skipped this+              -- pass, the current group's lexical dependencies must have been+              -- satisfied by the preceding groups; no need for the ready check,+              -- this avoids some lookups in tcg_env++          -- See Note [Expedient use of diagnostics in tcTyClGroupsPass]+          set_opts action+            | strict    = setWOptM Opt_WarnUnusableUnpackPragmas action+            | otherwise = action+          validate _ msgs _+            | strict    = not (unpackErrorsFound msgs)+            | otherwise = True++      if not ready then return on_blocked else+        tryTcDiscardingErrs' validate+                             (return on_flawed)+                             (return on_failed)+                             (on_success <$> set_opts (tcTyClGroup g))++data TcTyClGroupsStats =+  TcTyClGroupsStats+    { ttcgs_n_success   :: !Int   -- ^ Number of successfully checked groups+    , ttcgs_n_blocked   :: !Int   -- ^ Number of groups whose FVs are not in the env+    , ttcgs_n_failed    :: !Int   -- ^ Number of groups that failed with an error+    , ttcgs_n_flawed    :: !Int   -- ^ Number of groups that did not pass validation+    }++ttcgs_zero :: TcTyClGroupsStats+ttcgs_zero = TcTyClGroupsStats 0 0 0 0++ttcgs_inc_success, ttcgs_inc_blocked, ttcgs_inc_failed, ttcgs_inc_flawed :: TcTyClGroupsStats -> TcTyClGroupsStats+ttcgs_inc_success stats = stats { ttcgs_n_success = 1 + ttcgs_n_success stats }+ttcgs_inc_blocked stats = stats { ttcgs_n_blocked = 1 + ttcgs_n_blocked stats }+ttcgs_inc_failed  stats = stats { ttcgs_n_failed  = 1 + ttcgs_n_failed stats }+ttcgs_inc_flawed  stats = stats { ttcgs_n_flawed  = 1 + ttcgs_n_flawed stats }++instance Outputable TcTyClGroupsStats where+  ppr stats =+    vcat [ text "n_success =" <+> ppr (ttcgs_n_success stats)+         , text "n_blocked =" <+> ppr (ttcgs_n_blocked stats)+         , text "n_failed  =" <+> ppr (ttcgs_n_failed  stats)+         , text "n_flawed  =" <+> ppr (ttcgs_n_flawed  stats) ]++-- See Note [Expedient use of diagnostics in tcTyClGroupsPass]+unpackErrorsFound :: Messages TcRnMessage -> Bool+unpackErrorsFound = any is_unpack_error+  where+    is_unpack_error :: TcRnMessage -> Bool+    is_unpack_error (TcRnMessageWithInfo _ (TcRnMessageDetailed _ msg)) = is_unpack_error msg+    is_unpack_error (TcRnWithHsDocContext _ msg) = is_unpack_error msg+    is_unpack_error (TcRnBadFieldAnnotation _ _ UnusableUnpackPragma) = True+    is_unpack_error _ = False++{- Note [Expedient use of diagnostics in tcTyClGroupsPass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In tcTyClGroupsPass.go with strict=True, we want to skip "flawed" groups, i.e.+groups with unusable unpack pragmas, as explained in Note [Retrying TyClGroups].+To detect these unusable {-# UNPACK #-} pragmas, we currently piggy-back on the+diagnostics infrastructure:++  1. (setWOptM Opt_WarnUnusableUnpackPragmas) to enable the warning.+     The warning is on by default, but the user may have disabled it with+     -Wno-unusable-unpack-pragmas, in which case we need to turn it back on.++  2. (unpackErrorsFound msgs) to check if UnusableUnpackPragma is one of the+     collected diagnostics.  This is somewhat unpleasant because of the need to+     recurse into TcRnMessageWithInfo and TcRnWithHsDocContext.++Arguably, this is not a principled solution, because diagnostics are meant for+the user and here we inspect them to determine the order of type-checking. The+only reason for the current setup is that it was the easy thing to do.+-}++isReadyTyClGroup :: TcGblEnv -> TyClGroup GhcRn -> Bool+isReadyTyClGroup tcg_env TyClGroup{group_ext = deps} =+  nameSetAll (\n -> n `elemNameEnv` tcg_type_env tcg_env) deps+ tcTyClGroup :: TyClGroup GhcRn-            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)+            -> TcM (TcGblEnv, TcTyClGroupsAccum) -- Typecheck one strongly-connected component of type, class, and instance decls -- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds@@ -218,8 +557,13 @@            -- as we might look them up in checkTyConConsistentWithBoot.            -- See Note [TyCon boot consistency checking].           fmap concat . for tyclss_with_validity_infos $ \ (tycls, ax_validity_infos) ->-          do { tcAddFamInstCtxt (text "type family") (tyConName tycls) $-               tcAddClosedTypeFamilyDeclCtxt tycls $+          do { let inst_flav =+                     TyConInstFlavour+                       { tyConInstFlavour = tyConFlavour tycls+                       , tyConInstIsDefault = False+                       }+             ; tcAddFamInstCtxt inst_flav (tyConName tycls) $+               addErrCtxt (ClosedFamEqnCtxt tycls) $                  mapM_ (checkTyFamEqnValidityInfo tycls) ax_validity_infos              ; checkValidTyCl tycls } @@ -242,8 +586,10 @@        ; let deriv_info = datafam_deriv_info ++ data_deriv_info        ; let gbl_env'' = gbl_env'                 { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }-       ; return (gbl_env'', inst_info, deriv_info,-                 th_bndrs' `plusNameEnv` th_bndrs) }+       ; let acc = TcTyClGroupsAccum{ ttcga_inst_info  = toOL inst_info+                                    , ttcga_deriv_info = toOL deriv_info+                                    , ttcga_th_bndrs   = th_bndrs' `plusNameEnv` th_bndrs }+       ; return (gbl_env'', acc) }  -- Gives the kind for every TyCon that has a standalone kind signature type KindSigEnv = NameEnv Kind@@ -1135,7 +1481,7 @@              flav = tyConFlavour tc         -- Eta expand-       ; (eta_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind+       ; (eta_tcbs, tc_res_kind) <- maybeEtaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind         -- Step 6: Make the result TcTyCon        ; let final_tcbs = all_tcbs `chkAppend` eta_tcbs@@ -1252,7 +1598,7 @@  Note that neither code path worries about point (4) above, as this is nicely handled by not mangling the res_kind. (Mangling res_kinds is done-*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)+*after* all this stuff, in tcDataDefn's call to maybeEtaExpandAlgTyCon.)  We can tell Inferred apart from Specified by looking at the scoped tyvars; Specified are always included there.@@ -1759,7 +2105,9 @@ -- - In this function, those TcTyVars are unified with other kind variables during --   kind inference (see GHC.Tc.TyCl Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]) -kcTyClDecl (DataDecl { tcdLName    = (L _ _name), tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } }) tycon+kcTyClDecl (DataDecl { tcdLName    = (L _ _name)+                     , tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } })+           tycon   = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $        -- NB: binding these tyvars isn't necessary for GADTs, but it does no        -- harm.  For GADTs, each data con brings its own tyvars into scope,@@ -1767,7 +2115,7 @@        -- (conceivably) shadowed.     do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon))        ; _ <- tcHsContext ctxt-       ; kcConDecls (dataDefnConsNewOrData cons) (tyConResKind tycon) cons+       ; kcConDecls (tyConResKind tycon) cons        }  kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon@@ -1799,117 +2147,163 @@ -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments.-kcConArgTys :: NewOrData -> TcKind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM ()-kcConArgTys new_or_data res_kind arg_tys = do-  { let exp_kind = getArgExpKind new_or_data res_kind-  ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsTypeInContext (getBangType ty) exp_kind-                                             tcMult mult)+kcConArgTys :: ConArgKind                      -- Expected kind of the argument(s)+            -> [HsConDeclField GhcRn]          -- User-written argument types+            -> TcM ()+kcConArgTys exp_kind arg_tys+  = forM_ arg_tys $ \(CDF { cdf_multiplicity, cdf_type }) ->+    do { _ <- tcCheckLHsTypeInContext cdf_type exp_kind+       ; maybe (pure ()) (void . tcMult) (multAnnToHsType cdf_multiplicity) }     -- See Note [Implementation of UnliftedNewtypes], STEP 2-  }  -- Kind-check the types of arguments to a Haskell98 data constructor.-kcConH98Args :: NewOrData -> TcKind -> HsConDeclH98Details GhcRn -> TcM ()-kcConH98Args new_or_data res_kind con_args = case con_args of-  PrefixCon _ tys   -> kcConArgTys new_or_data res_kind tys-  InfixCon ty1 ty2  -> kcConArgTys new_or_data res_kind [ty1, ty2]-  RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $-                       map (hsLinear . cd_fld_type . unLoc) flds+kcConH98Args :: ConArgKind                       -- Expected kind of the argument(s)+             -> HsConDeclH98Details GhcRn+             -> TcM ()+kcConH98Args exp_kind con_args = case con_args of+  PrefixCon tys     -> kcConArgTys exp_kind tys+  InfixCon ty1 ty2  -> kcConArgTys exp_kind [ty1, ty2]+  RecCon (L _ flds) -> kcConArgTys exp_kind $+                       map (cdrf_spec . unLoc) flds  -- Kind-check the types of arguments to a GADT data constructor.-kcConGADTArgs :: NewOrData -> TcKind -> HsConDeclGADTDetails GhcRn -> TcM ()-kcConGADTArgs new_or_data res_kind con_args = case con_args of-  PrefixConGADT _ tys     -> kcConArgTys new_or_data res_kind tys-  RecConGADT _ (L _ flds) -> kcConArgTys new_or_data res_kind $-                             map (hsLinear . cd_fld_type . unLoc) flds+kcConGADTArgs :: ConArgKind                       -- Expected kind of the argument(s)+              -> HsConDeclGADTDetails GhcRn+              -> TcM ()+kcConGADTArgs exp_kind con_args = case con_args of+  PrefixConGADT _ tys     -> kcConArgTys exp_kind tys+  RecConGADT _ (L _ flds) -> kcConArgTys exp_kind $+                             map (cdrf_spec . unLoc) flds -kcConDecls :: Foldable f-           => NewOrData-           -> TcKind             -- The result kind signature-                               --   Used only in H98 case-           -> f (LConDecl GhcRn) -- The data constructors-           -> TcM ()+kcConDecls :: TcKind  -- Result kind of tycon+                      -- Used only in H98 case+           -> DataDefnCons (LConDecl GhcRn) -> TcM () -- See Note [kcConDecls: kind-checking data type decls]-kcConDecls new_or_data tc_res_kind = traverse_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind))+kcConDecls tc_res_kind cons+  = traverse_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons+  where+    new_or_data = dataDefnConsNewOrData cons  -- Kind check a data constructor. In additional to the data constructor, -- we also need to know about whether or not its corresponding type was -- declared with data or newtype, and we need to know the result kind of -- this type. See Note [Implementation of UnliftedNewtypes] for why -- we need the first two arguments.-kcConDecl :: NewOrData-          -> TcKind  -- Result kind of the type constructor-                   -- Usually Type but can be TYPE UnliftedRep-                   -- or even TYPE r, in the case of unlifted newtype-                   -- Used only in H98 case-          -> ConDecl GhcRn-          -> TcM ()-kcConDecl new_or_data tc_res_kind (ConDeclH98-  { con_name = name, con_ex_tvs = ex_tvs-  , con_mb_cxt = ex_ctxt, con_args = args })-  = addErrCtxt (dataConCtxt (NE.singleton name)) $+kcConDecl :: NewOrData -> TcKind -> ConDecl GhcRn -> TcM ()+kcConDecl new_or_data tc_res_kind+          (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs+                      , con_mb_cxt = ex_ctxt, con_args = args })+  = addErrCtxt (DataConDefCtxt (NE.singleton name)) $     discardResult                   $     bindExplicitTKBndrs_Tv ex_tvs $     do { _ <- tcHsContext ex_ctxt-       ; kcConH98Args new_or_data tc_res_kind args+       ; let arg_exp_kind = getArgExpKind new_or_data tc_res_kind+             -- getArgExpKind: for newtypes, check that the argument kind+             -- is the same as the tc_res_kind.  See (KCD1)+             -- in Note [kcConDecls: kind-checking data type decls]+       ; kcConH98Args arg_exp_kind args          -- We don't need to check the telescope here,          -- because that's done in tcConDecl        } -kcConDecl new_or_data-          _tc_res_kind   -- Not used in GADT case (and doesn't make sense)-          (ConDeclGADT-    { con_names = names, con_bndrs = L _ outer_bndrs, con_mb_cxt = cxt-    , con_g_args = args, con_res_ty = res_ty })+kcConDecl new_or_data _tc_res_kind+                      -- NB: _tc_res_kind is unused.   See (KCD3) in+                      -- Note [kcConDecls: kind-checking data type decls]+          (ConDeclGADT { con_names = names+                       , con_outer_bndrs = L _ outer_bndrs+                       , con_inner_bndrs = inner_bndrs+                       , con_mb_cxt = cxt+                       , con_g_args = args+                       , con_res_ty = res_ty })   = -- See Note [kcConDecls: kind-checking data type decls]-    addErrCtxt (dataConCtxt names) $-    discardResult                      $+    addErrCtxt (DataConDefCtxt names) $     -- Not sure this is right, should just extend rather than skolemise but no test-    bindOuterSigTKBndrs_Tv outer_bndrs $-        -- Why "_Tv"?  See Note [Using TyVarTvs for kind-checking GADTs]+    bind_con_tvbs outer_bndrs inner_bndrs $     do { _ <- tcHsContext cxt        ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty)        ; con_res_kind <- newOpenTypeKind        ; _ <- tcCheckLHsTypeInContext res_ty (TheKind con_res_kind)-       ; kcConGADTArgs new_or_data con_res_kind args-       ; traceTc "kcConDecl:GADT }" (ppr names $$ ppr con_res_kind)++       ; let arg_exp_kind = getArgExpKind new_or_data con_res_kind+             -- getArgExpKind: for newtypes, check that the argument kind+             -- is the same the kind of `res_ty`, the data con's return type+             -- See (KCD2) in Note [kcConDecls: kind-checking data type decls]+       ; kcConGADTArgs arg_exp_kind args++       ; traceTc "kcConDecl:GADT }" (ppr names $$ ppr arg_exp_kind)        ; return () }+  where+    bind_con_tvbs outer_bndrs inner_bndrs thing_inside+      -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs]+      = discardResult $ bindOuterSigTKBndrs_Tv outer_bndrs $+                        bindExplicitTKBndrs_Tv (concatMap hsForAllTelescopeBndrs inner_bndrs) $+                        thing_inside  {- Note [kcConDecls: kind-checking data type decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ kcConDecls is used when we are inferring the kind of the type-constructor in a data type declaration.  E.g.-    data T f a = MkT (f a)-we want to infer the kind of 'f' and 'a'. The basic plan is described-in Note [Inferring kinds for type declarations]; here we are doing Step 2.+constructor in a data type declaration. The basic plan is described in+Note [Inferring kinds for type declarations]; here we are doing Step 2. -In the GADT case we may have this:-   data T f a where-      MkT :: forall g b. g b -> T g b+We are kind-checking the data constructors /only/ to compute the kind of+the type construtor.  For example+       data T f a = MkT (f a)+The (f a) in the data construtor constrains the kinds of `f` and `a`, and hence+of `T`. -Notice that the variables f,a, and g,b are quite distinct.-Nevertheless, the type signature for MkT must still influence the kind-T which is (remember Step 1) something like-  T :: kappa1 -> kappa2 -> Type-Otherwise we'd infer the bogus kind-  T :: forall k1 k2. k1 -> k2 -> Type.+There are two cases to consider in `kcConDecl` -The type signature for MkT influences the kind of T simply by-kind-checking the result type (T g b), which will force 'f' and 'g' to-have the same kinds. This is the call to-    tcCheckLHsTypeInContext res_ty (TheKind con_res_kind)-Because this is the result type of an arrow, we know the kind must be-of form (TYPE rr), and we get better error messages if we enforce that-here (e.g. test gadt10).+* Haskell 98 data constructors, as above.  We simply bring `f` and `a`+  into scope and kind-check the data constructors. -For unlifted newtypes only, we must ensure that the argument kind-and result kind are the same:-* In the H98 case, we need the result kind of the TyCon, to unify with-  the argument kind.+* GADT data type decls e.g.+      data S f a where+         MkS :: g b -> S g b+  Here `f` and `a` don't scope over the data constructor signatures.+  Instead, we just kind-check the entire signature (including the result `S g b`),+  relying on the fact that `S` is in scope with its initial kind `k1 -> k2 -> Type`;+  doing so will constrain `k1` and `k2` appropriately. -* In GADT syntax, this unification happens via the result kind passed-  to kcConGADTArgs. The tycon's result kind is not used at all in the-  GADT case.+The arguments of each data constructor are always of kind (TYPE r) for some+r :: RuntimeRep.  But in the case of a newytype, the argument kind must be+the same as the tycon result kind.  Since we are trying to figure out the+tycon kind, kcConDecls must account for this, which is surprisingly tricky.+Again there are two cases to consider in `kcConDecl`: +* Haskell 98 data type decls, e.g.+       data T f a = MkT (f a)+  * In the header, all the tycon binders are specified (here `f` and `a`)+    and there is no result kind signature.+  * The binders from the header scope over the data construtors.+  * In the case of unlifted newtypes, the argument kind affects the tycon kind+       newtype N = MkN Int#+    Here `getInitialKind` will give `N` the result kind `TYPE r`, where `r` is+    a unification variable, and `kcConDecls` should unify that `r` with+    `IntRep` becuase of the `Int#`++  Solution (KCD1): just check that the argumet type has the same kind as the result+  kind of the tycon.++* GADT data type decls e.g.+       data S f :: Type -> Type where+          MkS :: g a -> S g a+  * In the header, not all the tycon binders are specified (here just `f`),+    and there can be a kind signature+  * The kind signature may describe some, all, or none of the tycon binders.+    Regardless, in the TcTyCon constructed by `getInitialKind`, the tyConResKind+    is the signature, not the "ultimate" result type of the tycon (which is+    usually Type)+  * In the case of unlifted newtypes, we again want the argument kind to be the+    same as the result kind of the tycon; but it's not so clear what /is/ the+    result kind of the tycon, because of the signature stuff in the previous bullet.++  Solution (KCD2): kind-check the result type of the data constructor (here+  `S g a`) and, for newtypes, ensure that the arugment has that same kind.++  (KCD3) The tycon's result kind `tc_res_kind` is not used at all in the GADT+  case; rather it is accessed via looking up S's kind in the type environment+  when kind-checking the result type of the data constructor.+ Note [Using TyVarTvs for kind-checking GADTs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -2083,7 +2477,7 @@      data T a :: Type -> Type where ...      we really mean for T to have two parameters. The second parameter-    is produced by processing the return kind in etaExpandAlgTyCon,+    is produced by processing the return kind in maybeEtaExpandAlgTyCon,     called in tcDataDefn.      See also Note [splitTyConKind] in GHC.Tc.Gen.HsType.@@ -2178,14 +2572,20 @@      Type. This assumption is in getInitialKind for CUSKs or      get_fam_decl_initial_kind for non-signature & non-CUSK cases. -   Instances: The data family already has a known kind. The return kind-     of an instance is then calculated by applying the data family tycon-     to the patterns provided, as computed by the typeKind lhs_ty in the-     end of tcDataFamInstHeader. In the case of an instance written in GADT-     syntax, there are potentially *two* return kinds: the one computed from-     applying the data family tycon to the patterns, and the one given by-     the user. This second kind is checked by the tc_kind_sig function within-     tcDataFamInstHeader. See also DF3, below.+    Instances: There are potentially *two* return kinds:+     * Master kind:+       The data family already has a known kind. The return kind of an instance+       is then calculated by applying the data family tycon to the patterns+       provided, as computed by the `tcFamTyPats fam_tc hs_pats` in the+       tcDataFamInstHeader.+     * Instance kind:+       The kind specified by the user in GADT syntax. If H98 syntax is used,+       with UnliftedNewtypes/UnliftedDatatypes, it defaults to newOpenTypeKind+       for newtypes/datatypes, otherwise it defaults to liftedTypeKind.+       This is checked or defaulted by the tc_kind_sig function within+       tcDataFamInstHeader. Defaulting can be tricky for some cases,+       See Note [Defaulting result kind of newtype/data family instance].+     See also DF3, below.  DF1 In a data/newtype instance, we treat the kind of the /data family/,     once instantiated, as the "master kind" for the representation@@ -2653,9 +3053,9 @@        -- and concrete class with no methods (maybe by        -- specifying a trailing where or not -       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff+       ; mindef  <- tcClassMinimalDef class_name sigs sig_stuff        ; is_boot <- tcIsHsBootOrSig-       ; let body | is_boot, isNothing hs_ctxt, null at_stuff, null sig_stuff+       ; let abstract_class = is_boot && isNothing hs_ctxt && null at_stuff && null sig_stuff                   -- We use @isNothing hs_ctxt@ rather than @null ctxt@,                   -- so that a declaration in an hs-boot file such as:                   --@@ -2664,11 +3064,19 @@                   -- is not considered abstract; it's sometimes useful                   -- to be able to declare such empty classes in hs-boot files.                   -- See #20661.-                  = Nothing-                  | otherwise-                  = Just (ctxt, at_stuff, sig_stuff, mindef) -       ; clas <- buildClass class_name bndrs roles fds body+             unary_class = case ctxt ++ map sndOf3 sig_stuff of+                              [ty] -> isBoxedType ty+                              _    -> False+                -- Use a unary class if the data constructor+                -- has exactly one, boxed value field+                -- i.e. exactly one operation or superclass taken together+                -- See (UCM10) in Note [Unary class magic] in GHC.Core.TyCon++       ; clas <- if abstract_class+                 then buildAbstractClass class_name bndrs roles fds+                 else buildClass class_name bndrs roles fds ctxt+                                 at_stuff sig_stuff mindef unary_class        ; traceTc "tcClassDecl" (ppr fundeps $$ ppr bndrs $$                                 ppr fds)        ; return clas }@@ -2752,8 +3160,15 @@                                    , feqn_pats  = hs_pats                                    , feqn_rhs   = hs_rhs_ty }})]   = -- See Note [Type-checking default assoc decls]+    let+       inst_flav =+         TyConInstFlavour+           { tyConInstFlavour = tyConFlavour fam_tc+           , tyConInstIsDefault = True+           }+    in     setSrcSpanA loc $-    tcAddFamInstCtxt (text "default type instance") tc_name $+    tcAddFamInstCtxt inst_flav tc_name $     do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)        ; let fam_tc_name = tyConName fam_tc              vis_arity = length (tyConVisibleTyVars fam_tc)@@ -3075,7 +3490,7 @@   where     skol_info = TyConSkol TypeSynonymFlavour tc_name -tcDataDefn :: SDoc -> RolesInfo -> Name+tcDataDefn :: ErrCtxtMsg -> RolesInfo -> Name            -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo])   -- NB: not used for newtype/data instances (whether associated or not) tcDataDefn err_ctxt roles_info tc_name@@ -3320,7 +3735,7 @@     no role.  See also Note [Re-quantify type variables in rules] in-GHC.Tc.Gen.Rule, which explains a /very/ similar design when+GHC.Tc.Gen.Sig, which explains a /very/ similar design when generalising over the type of a rewrite rule.  -}@@ -3606,7 +4021,7 @@                       , con_ex_tvs = explicit_tkv_nms                       , con_mb_cxt = hs_ctxt                       , con_args = hs_args })-  = addErrCtxt (dataConCtxt (NE.singleton lname)) $+  = addErrCtxt (DataConDefCtxt (NE.singleton lname)) $     do { -- NB: the tyvars from the declaration header are in scope           -- Get hold of the existential type variables@@ -3626,7 +4041,7 @@               do { ctxt <- tcHsContext hs_ctxt                  ; let exp_kind = getArgExpKind new_or_data res_kind                  ; btys <- tcConH98Args exp_kind hs_args-                 ; field_lbls <- lookupConstructorFields name+                 ; field_lbls <- lookupConstructorFields $ noUserRdr name                  ; let (arg_tys, stricts) = unzip btys                  ; return (ctxt, arg_tys, field_lbls, stricts)                  }@@ -3677,7 +4092,7 @@                 -- For H98 datatypes, the user-written tyvar binders are precisely                 -- the universals followed by the existentials.                 -- See Note [DataCon user type variable binders] in GHC.Core.DataCon.-             user_tvbs = univ_tvbs ++ ex_tvbs+             user_tvbs = tyVarSpecToBinders $ univ_tvbs ++ ex_tvbs              user_res_ty = mkDDHeaderTy dd_info rep_tycon tc_bndrs         ; traceTc "tcConDecl 2" (ppr name)@@ -3701,16 +4116,17 @@   -- NB: don't use res_kind here, as it's ill-scoped. Instead,   -- we get the res_kind by typechecking the result type.           (ConDeclGADT { con_names = names-                       , con_bndrs = L _ outer_hs_bndrs+                       , con_outer_bndrs = L _ outer_bndrs+                       , con_inner_bndrs = inner_bndrs                        , con_mb_cxt = cxt, con_g_args = hs_args                        , con_res_ty = hs_res_ty })-  = addErrCtxt (dataConCtxt names) $+  = addErrCtxt (DataConDefCtxt names) $     do { traceTc "tcConDecl 1 gadt" (ppr names)        ; let L _ name :| _ = names        ; skol_info <- mkSkolemInfo (DataConSkol name)-       ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))+       ; (tclvl, wanted, (tvbs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))            <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $-              tcOuterTKBndrs skol_info outer_hs_bndrs       $+              tcGadtConTyVarBndrs skol_info outer_bndrs inner_bndrs $               do { ctxt <- tcHsContext cxt                  ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty                          -- See Note [GADT return kinds]@@ -3724,8 +4140,8 @@                         do { (subst, _meta_tvs) <- newMetaTyVars (binderVars tc_bndrs)                            ; let head_shape = substTy subst hdr_ty                            ; discardResult $-                             popErrCtxt $  -- Drop dataConCtxt-                             addErrCtxt (dataConResCtxt names) $+                             popErrCtxt $  -- Drop DataConDefCtxt+                             addErrCtxt (DataConResTyCtxt names) $                              unifyType Nothing res_ty head_shape }                     -- See Note [Datatype return kinds]@@ -3733,22 +4149,19 @@                  ; btys <- tcConGADTArgs exp_kind hs_args                   ; let (arg_tys, stricts) = unzip btys-                 ; field_lbls <- lookupConstructorFields name+                 ; field_lbls <- lookupConstructorFields $ noUserRdr name                  ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)                  } -       ; outer_bndrs <- scopedSortOuter outer_bndrs-       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs-        ; tkvs <- kindGeneralizeAll skol_info-                    (mkInvisForAllTys outer_tv_bndrs $-                     tcMkPhiTy ctxt                  $-                     tcMkScaledFunTys arg_tys        $+                    (mkForAllTys tvbs         $+                     tcMkPhiTy ctxt           $+                     tcMkScaledFunTys arg_tys $                      res_ty)        ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs)        ; reportUnsolvedEqualities skol_info tkvs tclvl wanted -       ; let tvbndrs =  mkTyVarBinders InferredSpec tkvs ++ outer_tv_bndrs+       ; let tvbndrs = mkTyVarBinders Inferred tkvs ++ tvbs         -- Zonk to Types        ; (tvbndrs, arg_tys, ctxt, res_ty) <- initZonkEnv NoFlexi $@@ -3866,13 +4279,21 @@ tcInferLHsTypeKind doesn't any gratuitous top-level casts. -} ++type ConArgKind = ContextKind+  -- The expected kind of the argument(s) of a constructor+  -- For data types this is always OpenKind+  -- For newtypes it is (TheKind ki)+  --     where `ki` is the result kind of the newtype+  -- With NoUnliftedNewtype, ki=Type, but with UnliftedNewtypes it can be a variable+ -- | Produce an "expected kind" for the arguments of a data/newtype. -- If the declaration is indeed for a newtype, -- then this expected kind will be the kind provided. Otherwise, -- it is OpenKind for datatypes and liftedTypeKind. -- Why do we not check for -XUnliftedNewtypes? See point <Error Messages> -- in Note [Implementation of UnliftedNewtypes]-getArgExpKind :: NewOrData -> TcKind -> ContextKind+getArgExpKind :: NewOrData -> TcKind -> ConArgKind getArgExpKind NewType res_ki = TheKind res_ki getArgExpKind DataType _     = OpenKind @@ -3893,65 +4314,77 @@            RecConGADT{} -> return False            PrefixConGADT _ arg_tys       -- See Note [Infix GADT constructors]                | isSymOcc (getOccName con)-               , [_ty1,_ty2] <- map hsScaledThing arg_tys+               , [_ty1,_ty2] <- arg_tys                   -> do { fix_env <- getFixityEnv                         ; return (con `elemNameEnv` fix_env) }                | otherwise -> return False -tcConH98Args :: ContextKind  -- expected kind of arguments+tcConH98Args :: ConArgKind   -- expected kind of arguments                              -- always OpenKind for datatypes, but unlifted newtypes                              -- might have a specific kind              -> HsConDeclH98Details GhcRn              -> TcM [(Scaled TcType, HsSrcBang)]-tcConH98Args exp_kind (PrefixCon _ btys)-  = mapM (tcConArg exp_kind) btys+tcConH98Args exp_kind (PrefixCon btys)+  = mapM (tcConArg exp_kind IsNotPrefixConGADT) btys tcConH98Args exp_kind (InfixCon bty1 bty2)-  = do { bty1' <- tcConArg exp_kind bty1-       ; bty2' <- tcConArg exp_kind bty2+  = do { bty1' <- tcConArg exp_kind IsNotPrefixConGADT bty1+       ; bty2' <- tcConArg exp_kind IsNotPrefixConGADT bty2        ; return [bty1', bty2'] } tcConH98Args exp_kind (RecCon fields)-  = tcRecConDeclFields exp_kind fields+  = tcRecHsConDeclRecFields exp_kind fields -tcConGADTArgs :: ContextKind  -- expected kind of arguments+tcConGADTArgs :: ConArgKind   -- expected kind of arguments                               -- always OpenKind for datatypes, but unlifted newtypes                               -- might have a specific kind               -> HsConDeclGADTDetails GhcRn               -> TcM [(Scaled TcType, HsSrcBang)] tcConGADTArgs exp_kind (PrefixConGADT _ btys)-  = mapM (tcConArg exp_kind) btys+  = mapM (tcConArg exp_kind IsPrefixConGADT) btys tcConGADTArgs exp_kind (RecConGADT _ fields)-  = tcRecConDeclFields exp_kind fields+  = tcRecHsConDeclRecFields exp_kind fields -tcConArg :: ContextKind  -- expected kind for args; always OpenKind for datatypes,+tcConArg :: ConArgKind   -- expected kind for args; always OpenKind for datatypes,                          -- but might be an unlifted type with UnliftedNewtypes-         -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)-tcConArg exp_kind (HsScaled w bty)+         -> IsPrefixConGADT+         -> HsConDeclField GhcRn -> TcM (Scaled TcType, HsSrcBang)+tcConArg exp_kind isPrefixConGADT (CDF (_, src) unp str w bty _)   = do  { traceTc "tcConArg 1" (ppr bty)-        ; arg_ty <- tcCheckLHsTypeInContext (getBangType bty) exp_kind-        ; w' <- tcDataConMult w+        ; arg_ty <- tcCheckLHsTypeInContext bty exp_kind+        ; w' <- tcDataConMult isPrefixConGADT w         ; traceTc "tcConArg 2" (ppr bty)-        ; return (Scaled w' arg_ty, getBangStrictness bty) }+        ; return (Scaled w' arg_ty, HsSrcBang src unp str) } -tcRecConDeclFields :: ContextKind-                   -> LocatedL [LConDeclField GhcRn]+tcRecHsConDeclRecFields :: ConArgKind+                   -> LocatedL [LHsConDeclRecField GhcRn]                    -> TcM [(Scaled TcType, HsSrcBang)]-tcRecConDeclFields exp_kind fields-  = mapM (tcConArg exp_kind) btys+tcRecHsConDeclRecFields exp_kind fields+  = mapM (tcConArg exp_kind IsNotPrefixConGADT) btys   where     -- We need a one-to-one mapping from field_names to btys-    combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f)))+    combined = map (\(L _ f) -> (cdrf_names f, cdrf_spec f))                    (unLoc fields)     explode (ns,ty) = zip ns (repeat ty)     exploded = concatMap explode combined     (_,btys) = unzip exploded -tcDataConMult :: HsArrow GhcRn -> TcM Mult-tcDataConMult arr@(HsUnrestrictedArrow _) = do-  -- See Note [Function arrows in GADT constructors]-  linearEnabled <- xoptM LangExt.LinearTypes-  if linearEnabled then tcMult arr else return oneDataConTy-tcDataConMult arr = tcMult arr+data IsPrefixConGADT = IsPrefixConGADT | IsNotPrefixConGADT deriving (Eq) +-- See Note [Function arrows in GADT constructors]+unannotatedMultIsLinear :: IsPrefixConGADT -> TcRnIf gbl lcl Bool+unannotatedMultIsLinear isPrefixConGADT = do+  if isPrefixConGADT == IsPrefixConGADT then do+    linearEnabled <- xoptM LangExt.LinearTypes+    return $ not linearEnabled+  else+    return True++tcDataConMult :: IsPrefixConGADT -> HsMultAnn GhcRn -> TcM Mult+tcDataConMult isPrefixConGADT arr = case multAnnToHsType arr of+  Nothing -> do+    isLinear <- unannotatedMultIsLinear isPrefixConGADT+    return $ if isLinear then oneDataConTy else manyDataConTy+  Just ty -> tcMult ty+ {- Note [Function arrows in GADT constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -4015,11 +4448,11 @@ rejigConRes :: [KnotTied TyConBinder]  -- Template for result type; e.g.             -> KnotTied Type           -- data instance T [a] b c ...                                        --      gives template ([a,b,c], T [a] b c)-            -> [InvisTVBinder]    -- The constructor's type variables (both inferred and user-written)+            -> [TyVarBinder]      -- The constructor's type variables (both inferred and user-written)             -> KnotTied Type      -- res_ty             -> ([TyVar],          -- Universal                 [TyVar],          -- Existential (distinct OccNames from univs)-                [InvisTVBinder],  -- The constructor's rejigged, user-written+                [TyVarBinder],    -- The constructor's rejigged, user-written                                   -- type variables                 [EqSpec],         -- Equality predicates                 Subst)            -- Substitution to apply to argument types@@ -4232,7 +4665,7 @@   = choose [] [] empty_subst empty_subst tmpl_tvs   where     in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)-               `unionInScope` getSubstInScope subst+               `unionInScope` substInScopeSet subst     empty_subst = mkEmptySubst in_scope      choose :: [TyVar]        -- accumulator of univ tvs, reversed@@ -4507,7 +4940,7 @@             | Just fam_flav <- famTyConFlav_maybe tc               -> case fam_flav of                { ClosedSynFamilyTyCon (Just ax)-                   -> tcAddClosedTypeFamilyDeclCtxt tc $+                   -> addErrCtxt (ClosedFamEqnCtxt tc) $                       checkValidCoAxiom ax                ; ClosedSynFamilyTyCon Nothing   -> return ()                ; AbstractClosedSynFamilyTyCon ->@@ -4608,13 +5041,13 @@         ; checkTc (isJust mb_subst2) (TcRnCommonFieldTypeMismatch con1 con2 fld) }   where     mb_subst1 = tcMatchTy res1 res2-    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2+    mb_subst2 = tcMatchTyX (expectJust mb_subst1) fty1 fty2  ------------------------------- checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con   = setSrcSpan con_loc $-    addErrCtxt (dataConCtxt (NE.singleton (L (noAnnSrcSpan con_loc) con_name))) $+    addErrCtxt (DataConDefCtxt (NE.singleton (L (noAnnSrcSpan con_loc) con_name))) $     do  { let tc_tvs      = tyConTyVars tc               res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)               arg_tys     = dataConOrigArgTys con@@ -4690,38 +5123,38 @@           -- See Note [Type data declarations] in GHC.Rename.Module,           -- restriction (R4).         ; when (isTypeDataCon con) $-          checkTc (all isEqPred (dataConOtherTheta con))+          checkTc (all isEqClassPred (dataConOtherTheta con))                   (TcRnConstraintInKind (dataConRepType con))          ; hsc_env <- getTopEnv         ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()               check_bang orig_arg_ty bang rep_bang n-               | HsSrcBang _ (HsBang _ SrcLazy) <- bang+               | HsSrcBang _  _ SrcLazy <- bang                , not (bang_opt_strict_data bang_opts)                = addErrTc (bad_bang n LazyFieldsDisabled)                 -- Warn about UNPACK without "!"                -- e.g.   data T = MkT {-# UNPACK #-} Int-               | HsSrcBang _ (HsBang want_unpack strict_mark) <- bang+               | HsSrcBang _ want_unpack strict_mark <- bang                , isSrcUnpacked want_unpack, not (is_strict strict_mark)                , not (isUnliftedType orig_arg_ty)                = addDiagnosticTc (bad_bang n UnpackWithoutStrictness)                 -- Warn about a redundant ! on an unlifted type                -- e.g.   data T = MkT !Int#-               | HsSrcBang _ (HsBang _ SrcStrict) <- bang+               | HsSrcBang _ _ SrcStrict <- bang                , isUnliftedType orig_arg_ty                = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty                 -- Warn about a ~ on an unlifted type (#21951)                -- e.g.   data T = MkT ~Int#-               | HsSrcBang _ (HsBang _ SrcLazy) <- bang+               | HsSrcBang _ _ SrcLazy <- bang                , isUnliftedType orig_arg_ty                = addDiagnosticTc $ TcRnLazyBangOnUnliftedType orig_arg_ty                 -- Warn about unusable UNPACK pragmas                -- e.g.   data T a = MkT {-# UNPACK #-} !a      -- Can't unpack-               | HsSrcBang _ (HsBang want_unpack _) <- bang+               | HsSrcBang _ want_unpack _ <- bang                 -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon.                , isSrcUnpacked want_unpack  -- this means the user wrote {-# UNPACK #-}@@ -4734,7 +5167,7 @@                -- warn in this case (it gives users the wrong idea about whether                -- or not UNPACK on abstract types is supported; it is!)                , isHomeUnitDefinite (hsc_home_unit hsc_env)-               = addDiagnosticTc (bad_bang n BackpackUnpackAbstractType)+               = addDiagnosticTc (bad_bang n UnusableUnpackPragma)                 | otherwise                = return ()@@ -4820,9 +5253,9 @@     (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)       = dataConFullSig con -    ok_bang (HsSrcBang _ (HsBang _ SrcStrict)) = False-    ok_bang (HsSrcBang _ (HsBang _ SrcLazy))   = False-    ok_bang _                                  = True+    ok_bang (HsSrcBang _ _ SrcStrict) = False+    ok_bang (HsSrcBang _ _ SrcLazy)   = False+    ok_bang _                         = True      ok_mult OneTy = True     ok_mult _     = False@@ -4872,7 +5305,7 @@      check_op constrained_class_methods (sel_id, dm)       = setSrcSpan (getSrcSpan sel_id) $-        addErrCtxt (classOpCtxt sel_id op_ty) $ do+        addErrCtxt (ClassOpCtxt sel_id op_ty) $ do         { traceTc "class op type" (ppr op_ty)         ; checkValidType ctxt op_ty                 -- This implements the ambiguity check, among other things@@ -4928,8 +5361,15 @@                   , vi_non_user_tvs = non_user_tvs                   , vi_pats         = pats                   , vi_rhs          = orig_rhs } ->+                 let+                    inst_flav =+                      TyConInstFlavour+                        { tyConInstFlavour = tyConFlavour fam_tc+                        , tyConInstIsDefault = True+                        }+                 in                  setSrcSpan loc $-                 tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $+                 tcAddFamInstCtxt inst_flav (getName fam_tc) $                  do { checkValidAssocTyFamDeflt fam_tc pats                     ; checkFamPatBinders fam_tc qtvs non_user_tvs pats orig_rhs                     ; checkValidTyFamEqn fam_tc pats orig_rhs }}@@ -5001,9 +5441,10 @@           --           --    foo2         :: a -> Int           --    default foo2 :: a -> b-          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]-                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $-               TcRnDefaultSigMismatch sel_id dm_ty+          unless (isJust (tcMatchTy dm_phi_ty vanilla_phi_ty) &&+                  isJust (tcMatchTy vanilla_phi_ty dm_phi_ty)) $+            addErrTc $+            TcRnDefaultSigMismatch sel_id dm_ty            -- Now do an ambiguity check on the default type signature.           checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)@@ -5260,7 +5701,7 @@           warnIf (not (isClassTyCon tc) && not (null vis_roles)) $           TcRnMissingRoleAnnotation name vis_roles       Just (decl@(L loc (RoleAnnotDecl _ _ the_role_annots))) ->-          addRoleAnnotCtxt name $+          addErrCtxt (RoleAnnotErrCtxt name) $           setSrcSpanA loc $ do           { role_annots_ok <- xoptM LangExt.RoleAnnotations           ; unless role_annots_ok $ addErrTc $ TcRnRoleAnnotationsDisabled tc@@ -5405,9 +5846,9 @@ ************************************************************************ -} -tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc-tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,-                      text "declaration for", quotes (ppr (tcdName decl))]+tcMkDeclCtxt :: TyClDecl GhcRn -> ErrCtxtMsg+tcMkDeclCtxt decl =+  TyConDeclCtxt (tcdName decl) (tyClDeclFlavour decl)  addVDQNote :: TcTyCon -> TcM a -> TcM a -- See Note [Inferring visible dependent quantification]@@ -5415,7 +5856,7 @@ addVDQNote tycon thing_inside   | assertPpr (isMonoTcTyCon tycon) (ppr tycon $$ ppr tc_kind)     has_vdq-  = addLandmarkErrCtxt vdq_warning thing_inside+  = addLandmarkErrCtxt (VDQWarningCtxt tycon) thing_inside   | otherwise   = thing_inside   where@@ -5432,62 +5873,41 @@     is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) &&                      isVisibleTyConBinder tcb -    vdq_warning = vcat-      [ text "NB: Type" <+> quotes (ppr tycon) <+>-        text "was inferred to use visible dependent quantification."-      , text "Most types with visible dependent quantification are"-      , text "polymorphically recursive and need a standalone kind"-      , text "signature. Perhaps supply one, with StandaloneKindSignatures."-      ]- tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a tcAddDeclCtxt decl thing_inside   = addErrCtxt (tcMkDeclCtxt decl) thing_inside -tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a-tcAddTyFamInstCtxt decl-  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)--tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc-tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = eqn })-  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")-                    (unLoc (feqn_tycon eqn))--tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a-tcAddDataFamInstCtxt decl-  = addErrCtxt (tcMkDataFamInstCtxt decl)--tcMkFamInstCtxt :: SDoc -> Name -> SDoc-tcMkFamInstCtxt flavour tycon-  = hsep [ text "In the" <+> flavour <+> text "declaration for"-         , quotes (ppr tycon) ]--tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a-tcAddFamInstCtxt flavour tycon thing_inside-  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside--tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a-tcAddClosedTypeFamilyDeclCtxt tc-  = addErrCtxt ctxt+tcAddOpenTyFamInstCtxt :: AssocInstInfo -> TyFamInstDecl GhcRn -> TcM a -> TcM a+tcAddOpenTyFamInstCtxt mb_assoc decl+  = tcAddFamInstCtxt flav (tyFamInstDeclName decl)   where-    ctxt = text "In the equations for closed type family" <+>-           quotes (ppr tc)--dataConCtxt :: NonEmpty (LocatedN Name) -> SDoc-dataConCtxt cons = text "In the definition of data constructor" <> plural (toList cons)-                   <+> ppr_cons (toList cons)+    assoc = case mb_assoc of+      NotAssociated -> Nothing+      InClsInst { ai_class = cls } -> Just $ classTyCon cls+    flav = TyConInstFlavour+         { tyConInstFlavour = OpenFamilyFlavour IAmType assoc+         , tyConInstIsDefault = False+         } -dataConResCtxt :: NonEmpty (LocatedN Name) -> SDoc-dataConResCtxt cons = text "In the result type of data constructor" <> plural (toList cons)-                      <+> ppr_cons (toList cons)+tcMkDataFamInstCtxt :: AssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> ErrCtxtMsg+tcMkDataFamInstCtxt mb_assoc new_or_data (DataFamInstDecl { dfid_eqn = eqn })+  = TyConInstCtxt (unLoc (feqn_tycon eqn))+      (TyConInstFlavour+        { tyConInstFlavour   = OpenFamilyFlavour (IAmData new_or_data) assoc+        , tyConInstIsDefault = False+        })+  where+    assoc = case mb_assoc of+      NotAssociated -> Nothing+      InClsInst { ai_class = cls } -> Just $ classTyCon cls -ppr_cons :: [LocatedN Name] -> SDoc-ppr_cons [con] = quotes (ppr con)-ppr_cons cons  = interpp'SP cons+tcAddDataFamInstCtxt :: AssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> TcM a -> TcM a+tcAddDataFamInstCtxt assoc new_or_data decl+  = addErrCtxt (tcMkDataFamInstCtxt assoc new_or_data decl) -classOpCtxt :: Var -> Type -> SDoc-classOpCtxt sel_id tau = sep [text "When checking the class method:",-                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]+tcAddFamInstCtxt :: TyConInstFlavour -> Name -> TcM a -> TcM a+tcAddFamInstCtxt flavour tycon thing_inside+  = addErrCtxt (TyConInstCtxt tycon flavour) thing_inside  illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () illegalRoleAnnotDecl (L loc role)@@ -5496,12 +5916,7 @@     addErrTc $ TcRnIllegalRoleAnnotation role  addTyConCtxt :: TyCon -> TcM a -> TcM a-addTyConCtxt tc = addTyConFlavCtxt name flav+addTyConCtxt tc = addErrCtxt (TyConDeclCtxt name flav)   where     name = getName tc     flav = tyConFlavour tc--addRoleAnnotCtxt :: Name -> TcM a -> TcM a-addRoleAnnotCtxt name-  = addErrCtxt $-    text "while checking a role annotation for" <+> quotes (ppr name)
compiler/GHC/Tc/TyCl/Build.hs view
@@ -9,7 +9,8 @@ module GHC.Tc.TyCl.Build (         buildDataCon,         buildPatSyn,-        TcMethInfo, MethInfo, buildClass,+        TcMethInfo, MethInfo,+        buildClass, buildAbstractClass,         mkNewTyConRhs,         newImplicitBinder, newTyConRepName     ) where@@ -154,7 +155,7 @@            -> [FieldLabel]             -- Field labels            -> [TyVar]                  -- Universals            -> [TyCoVar]                -- Existentials-           -> [InvisTVBinder]          -- User-written 'TyVarBinder's+           -> [TyVarBinder]            -- User-written 'TyVarBinder's            -> [EqSpec]                 -- Equality spec            -> KnotTied ThetaType       -- Does not include the "stupid theta"                                        -- or the GADT equalities@@ -183,14 +184,15 @@               tag = lookupNameEnv_NF tag_map src_name               -- See Note [Constructor tag allocation], fixes #14657               data_con = mkDataCon src_name declared_infix prom_info-                                   src_bangs field_lbls+                                   src_bangs impl_bangs str_marks field_lbls                                    univ_tvs ex_tvs                                    noConcreteTyVars                                    user_tvbs eq_spec ctxt                                    arg_tys res_ty NoPromInfo rep_tycon tag                                    stupid_ctxt dc_wrk dc_rep               dc_wrk = mkDataConWorkId work_name data_con-              dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)+              (dc_rep, impl_bangs, str_marks) =+                 initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)          ; traceIf (text "buildDataCon 2" <+> ppr src_name)         ; return data_con }@@ -290,26 +292,14 @@            -> [TyConBinder]                -- Of the tycon            -> [Role]            -> [FunDep TyVar]               -- Functional dependencies-           -- Super classes, associated types, method info, minimal complete def.-           -- This is Nothing if the class is abstract.-           -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)+           -> KnotTied ThetaType     -- Superclasess+           -> [ClassATItem]          -- Associated types+           -> [KnotTied MethInfo]    -- Methods+           -> ClassMinimalDef        -- Minimal complete definition+           -> Bool                   -- True <=> is a unary class            -> TcRnIf m n Class -buildClass tycon_name binders roles fds Nothing-  = fixM  $ \ rec_clas ->       -- Only name generation inside loop-    do  { traceIf (text "buildClass")--        ; tc_rep_name  <- newTyConRepName tycon_name-        ; let univ_tvs = binderVars binders-              tycon = mkClassTyCon tycon_name binders roles-                                   AbstractTyCon-                                   rec_clas tc_rep_name-              result = mkAbstractClass tycon_name univ_tvs fds tycon-        ; traceIf (text "buildClass" <+> ppr tycon)-        ; return result }--buildClass tycon_name binders roles fds-           (Just (sc_theta, at_items, sig_stuff, mindef))+buildClass tycon_name binders roles fds sc_theta at_items sig_stuff mindef unary_class   = fixM  $ \ rec_clas ->       -- Only name generation inside loop     do  { traceIf (text "buildClass") @@ -332,22 +322,11 @@               -- (We used to call them D_C, but now we can have two different               --  superclasses both called C!) -        ; let use_newtype = isSingleton (sc_theta ++ op_tys)-                -- Use a newtype if the data constructor-                --   (a) has exactly one value field-                --       i.e. exactly one operation or superclass taken together-                --   (b) that value is of lifted type (which they always are, because-                --       we box equality superclasses)-                -- See Note [Class newtypes and equality predicates]-                ---                -- In the case of-                --     class C a => D a-                -- we use a newtype, but with one superclass and no arguments-              args       = sc_sel_names ++ op_names+        ; let args       = sc_sel_names ++ op_names               op_tys     = [ty | (_,ty,_) <- sig_stuff]               op_names   = [op | (op,_,_) <- sig_stuff]               rec_tycon  = classTyCon rec_clas-              univ_bndrs = tyConInvisTVBinders binders+              univ_bndrs = tyVarSpecToBinders $ tyConInvisTVBinders binders               univ_tvs   = binderVars univ_bndrs               bang_opts  = FixedBangOpts (map (const HsLazy) args) @@ -369,17 +348,16 @@                                    rec_tycon                                    (mkTyConTagMap rec_tycon) -        ; rhs <- case () of-                  _ | use_newtype-                    -> mkNewTyConRhs tycon_name rec_tycon dict_con-                    | isCTupleTyConName tycon_name-                    -> return (TupleTyCon { data_con = dict_con-                                          , tup_sort = ConstraintTuple })-                    | otherwise-                    -> return (mkDataTyConRhs [dict_con])+        ; let rhs | unary_class+                  = UnaryClassTyCon dict_con+                  | isCTupleTyConName tycon_name+                  = TupleTyCon { data_con = dict_con+                               , tup_sort = ConstraintTuple }+                  | otherwise+                  = mkDataTyConRhs [dict_con] -        ; let { tycon = mkClassTyCon tycon_name binders roles-                                     rhs rec_clas tc_rep_name+              tycon = mkClassTyCon tycon_name binders roles+                                   rhs rec_clas tc_rep_name                 -- A class can be recursive, and in the case of newtypes                 -- this matters.  For example                 --      class C a where { op :: C b => a -> b -> Int }@@ -389,14 +367,14 @@                 -- newtype like a synonym, but that will lead to an infinite                 -- type] -              ; result = mkClass tycon_name univ_tvs fds-                                 sc_theta sc_sel_ids at_items-                                 op_items mindef tycon-              }+              result = mkClass tycon_name univ_tvs fds+                               sc_theta sc_sel_ids at_items+                               op_items mindef tycon+         ; traceIf (text "buildClass" <+> ppr tycon)         ; return result }   where-    no_bang = mkHsSrcBang NoSourceText NoSrcUnpack NoSrcStrict+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict      mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem     mk_op_item rec_clas (op_name, _, dm_spec)@@ -414,23 +392,24 @@       = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc            ; return (Just (dm_name, GenericDM dm_ty)) } -{--Note [Class newtypes and equality predicates]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-        class (a ~ F b) => C a b where-          op :: a -> b+buildAbstractClass :: Name+                   -> [TyConBinder]+                   -> [Role]+                   -> [FunDep TyVar]+                   -> TcRnIf m n Class -We cannot represent this by a newtype, even though it's not-existential, because there are two value fields (the equality-predicate and op. See #2238+buildAbstractClass tycon_name binders roles fds+  = fixM  $ \ rec_clas ->       -- Only name generation inside loop+    do  { traceIf (text "buildClass") -Moreover,-          class (a ~ F b) => C a b where {}-Here we can't use a newtype either, even though there is only-one field, because equality predicates are unboxed, and classes-are boxed.--}+        ; tc_rep_name  <- newTyConRepName tycon_name+        ; let univ_tvs = binderVars binders+              tycon = mkClassTyCon tycon_name binders roles+                                   AbstractTyCon+                                   rec_clas tc_rep_name+              result = mkAbstractClass tycon_name univ_tvs fds tycon+        ; traceIf (text "buildClass" <+> ppr tycon)+        ; return result }  newImplicitBinder :: Name                       -- Base name                   -> (OccName -> OccName)       -- Occurrence name modifier
compiler/GHC/Tc/TyCl/Class.hs view
@@ -53,7 +53,6 @@  import GHC.Driver.DynFlags -import GHC.Types.Error import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env@@ -344,7 +343,7 @@   where     -- By default require all methods without a default implementation     defMindef :: ClassMinimalDef-    defMindef = mkAnd [ noLocA (mkVar name)+    defMindef = mkAnd [ noLocA (mkVar (noLocA name))                       | (name, _, Nothing) <- op_info ]  instantiateMethod :: Class -> TcId -> [TcType] -> TcType@@ -402,8 +401,8 @@ findMinimalDef = firstJusts . map toMinimalDef   where     toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef-    toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)-    toMinimalDef _                               = Nothing+    toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just bf+    toMinimalDef _                             = Nothing  {- Note [Polymorphic methods]@@ -464,23 +463,19 @@ badDmPrag sel_id prag   = addErrTc (TcRnDefaultMethodForPragmaLacksBinding sel_id prag) -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc+instDeclCtxt1 :: LHsSigType GhcRn -> ErrCtxtMsg instDeclCtxt1 hs_inst_ty-  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))+  = InstDeclErrCtxt (Left $ getLHsInstDeclHead hs_inst_ty) -instDeclCtxt2 :: Type -> SDoc+instDeclCtxt2 :: Type -> ErrCtxtMsg instDeclCtxt2 dfun_ty   = instDeclCtxt3 cls tys   where     (_,_,cls,tys) = tcSplitDFunTy dfun_ty -instDeclCtxt3 :: Class -> [Type] -> SDoc+instDeclCtxt3 :: Class -> [Type] -> ErrCtxtMsg instDeclCtxt3 cls cls_tys-  = inst_decl_ctxt (ppr (mkClassPred cls cls_tys))--inst_decl_ctxt :: SDoc -> SDoc-inst_decl_ctxt doc = hang (text "In the instance declaration for")-                        2 (quotes doc)+  = InstDeclErrCtxt (Right $ mkClassPred cls cls_tys)  tcATDefault :: SrcSpan             -> Subst
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -43,48 +44,53 @@ import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated )-import GHC.Core.Multiplicity-import GHC.Core.InstEnv import GHC.Tc.Instance.Family-import GHC.Core.FamInstEnv+ import GHC.Tc.Deriv import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType import GHC.Tc.Utils.Unify+import GHC.Tc.Types.Evidence+ import GHC.Builtin.Names ( unsatisfiableIdName )-import GHC.Core        ( Expr(..), mkApps, mkVarApps, mkLams )++import GHC.Core        ( Expr(..), mkVarApps ) import GHC.Core.Make   ( nO_METHOD_BINDING_ERROR_ID )-import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding )+import GHC.Core.Unfold.Make ( mkDFunUnfolding )+import GHC.Core.FamInstEnv import GHC.Core.Type-import GHC.Core.SimpleOpt+import GHC.Core.Multiplicity+import GHC.Core.InstEnv import GHC.Core.Predicate( classMethodInstTy )-import GHC.Tc.Types.Evidence import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.Class-import GHC.Types.Error+ import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set-import GHC.Data.Bag import GHC.Types.Basic import GHC.Types.Fixity-import GHC.Driver.DynFlags-import GHC.Driver.Ppr-import GHC.Utils.Logger-import GHC.Data.FastString import GHC.Types.Id import GHC.Types.SourceFile import GHC.Types.SourceText-import GHC.Data.List.SetOps import GHC.Types.Name import GHC.Types.Name.Set+import GHC.Types.SrcLoc++import GHC.Driver.DynFlags+import GHC.Driver.Ppr++import GHC.Utils.Logger import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Types.SrcLoc import GHC.Utils.Misc++import GHC.Data.FastString+import GHC.Data.List.SetOps+import GHC.Data.Bag import GHC.Data.BooleanFormula ( isUnsatisfied ) import qualified GHC.LanguageExtensions as LangExt @@ -184,6 +190,8 @@  Note [ClassOp/DFun selection] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This important Note explains how DFunIds and ClassOps work.+ One thing we see a lot is stuff like     op2 (df d1 d2) where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*@@ -218,6 +226,12 @@       let d = df d1 d2       in ...(op2 d)...(op1 d)... + * ClassOps have no unfolding; they work /only/ through their RULE.+   But a ClassOp might be called with no arguments, or with an argument that+   the rule doesn't fire on.   So each ClassOp does get an executable top-level+   definition, injected by GHC.Iface.Tidy.getClassImplicitBinds, which uses+   `GHC.Types.Id.Make.mkDictSelRhs` to make the code.+ Note [Single-method classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the class has just one method (or, more accurately, just one element@@ -352,10 +366,9 @@  Conclusion: when typechecking the methods in a C [a] instance, we want to treat the 'a' as an *existential* type variable, in the sense described-by Note [Binding when looking up instances].  That is why isOverlappableTyVar-responds True to an InstSkol, which is the kind of skolem we use in-tcInstDecl2.-+by Note [Super skolems: binding when looking up instances] in GHC.Core.InstEnv+That is why isOverlappableTyVar responds True to an InstSkol, which is the kind+of skolem we use in tcInstDecl2.  Note [Tricky type variable scoping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -419,8 +432,8 @@   -> [LDerivDecl GhcRn]   -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn) tcInstDeclsDeriv deriv_infos derivds-  = do th_stage <- getStage -- See Note [Deriving inside TH brackets]-       if isBrackStage th_stage+  = do th_lvl <- getThLevel -- See Note [Deriving inside TH brackets]+       if isBrackLevel th_lvl        then do { gbl_env <- getGblEnv                ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }        else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds@@ -496,7 +509,8 @@     do  { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty         ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty              -- NB: tcHsClsInstType does checkValidInstance-        ; skol_info <- mkSkolemInfo (mkClsInstSkol clas inst_tys)+        ; skol_info <- mkSkolemInfo (InstSkol IsClsInst pSizeZero)+                       -- pSizeZero: here the size part of InstSkol is irrelevant         ; (subst, skol_tvs) <- tcInstSkolTyVars skol_info tyvars         ; let tv_skol_prs = [ (tyVarName tv, skol_tv)                             | (tv, skol_tv) <- tyvars `zip` skol_tvs ]@@ -507,7 +521,7 @@                            fst $ splitForAllForAllTyBinders dfun_ty               visible_skol_tvs = drop n_inferred skol_tvs -        ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs)+        ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleBndrCount dfun_ty) $$ ppr skol_tvs)          -- Next, process any associated types.         ; (datafam_stuff, tyfam_insts)@@ -591,8 +605,8 @@   -- "type instance"; open type families only   -- See Note [Associated type instances] tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))-  = setSrcSpanA loc           $-    tcAddTyFamInstCtxt decl  $+  = setSrcSpanA loc                        $+    tcAddOpenTyFamInstCtxt mb_clsinfo decl $     do { let fam_lname = feqn_tycon eqn        ; fam_tc <- tcLookupLocatedTyCon fam_lname        ; tcFamInstDeclChecks mb_clsinfo IAmType fam_tc@@ -700,11 +714,11 @@                                         , dd_cons    = hs_cons                                         , dd_kindSig = m_ksig                                         , dd_derivs  = derivs } }}))-  = setSrcSpanA loc            $-    tcAddDataFamInstCtxt decl  $+  = setSrcSpanA loc                      $+    tcAddDataFamInstCtxt mb_clsinfo new_or_data decl $     do { fam_tc <- tcLookupLocatedTyCon lfam_name -       ; tcFamInstDeclChecks mb_clsinfo IAmData fam_tc+       ; tcFamInstDeclChecks mb_clsinfo (IAmData new_or_data) fam_tc         -- Check that the family declaration is for the right kind        ; checkTc (isDataFamilyTyCon fam_tc) $@@ -714,10 +728,9 @@           -- Do /not/ check that the number of patterns = tyConArity fam_tc           -- See [Arity of data families] in GHC.Core.FamInstEnv        ; skol_info <- mkSkolemInfo FamInstSkol-       ; let new_or_data = dataDefnConsNewOrData hs_cons        ; (qtvs, non_user_tvs, pats, tc_res_kind, stupid_theta)              <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity-                                    hs_ctxt hs_pats m_ksig new_or_data+                                    hs_ctxt hs_pats m_ksig hs_cons         -- Eta-reduce the axiom if possible        -- Quite tricky: see Note [Implementing eta reduction for data families]@@ -742,8 +755,7 @@        --     we did it before the "extra" tvs from etaExpandAlgTyCon        --     would always be eta-reduced        ---       ; let flav = newOrDataToFlavour new_or_data-       ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info full_tcbs tc_res_kind+       ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon skol_info full_tcbs tc_res_kind         -- Check the result kind; it may come from a user-written signature.        -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a)@@ -845,11 +857,15 @@                  Just $ DerivInfo { di_rep_tc     = rep_tc                                   , di_scoped_tvs = scoped_tvs                                   , di_clauses    = preds-                                  , di_ctxt       = tcMkDataFamInstCtxt decl }+                                  , di_ctxt       = tcMkDataFamInstCtxt mb_clsinfo new_or_data decl+                                  }         ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom        ; return (fam_inst, m_deriv_info) }   where++    new_or_data = dataDefnConsNewOrData hs_cons+     eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])     -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom     -- Splits the incoming patterns into two: the [TyVar]@@ -917,8 +933,7 @@ tcDataFamInstHeader     :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn     -> LexicalFixity -> Maybe (LHsContext GhcRn)-    -> HsFamEqnPats GhcRn -> Maybe (LHsKind GhcRn)-    -> NewOrData+    -> HsFamEqnPats GhcRn -> Maybe (LHsKind GhcRn) -> DataDefnCons (LConDecl GhcRn)     -> TcM ([TcTyVar], TyVarSet, [TcType], TcKind, TcThetaType)          -- All skolem TcTyVars, all zonked so it's clear what the free vars are -- The "header" of a data family instance is the part other than@@ -926,7 +941,7 @@ --    e.g.  data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where" tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity-                    hs_ctxt hs_pats m_ksig new_or_data+                    hs_ctxt hs_pats m_ksig hs_cons   = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats)        ; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))             <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $@@ -942,16 +957,17 @@                   -- with its parent class                   ; addConsistencyConstraints mb_clsinfo lhs_ty -                  -- Add constraints from the result signature-                  ; res_kind <- tc_kind_sig m_ksig--                  -- Do not add constraints from the data constructors-                  -- See Note [Kind inference for data family instances]+                  -- Add constraints from the data constructors+                  -- Fix #25611+                  -- See DESIGN CHOICE in Note [Kind inference for data family instances]+                  ; when is_H98_or_newtype $ kcConDecls lhs_applied_kind hs_cons                    -- Check that the result kind of the TyCon applied to its args                   -- is compatible with the explicit signature (or Type, if there                   -- is none)-                  ; let hs_lhs = nlHsTyConApp NotPromoted fixity (getName fam_tc) hs_pats+                  ; let hs_lhs = nlHsTyConApp NotPromoted fixity (noUserRdr $ getName fam_tc) hs_pats+                  -- Add constraints from the result signature+                  ; res_kind <- tc_kind_sig m_ksig                   ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind                    ; traceTc "tcDataFamInstHeader" $@@ -1003,9 +1019,16 @@   where     fam_name  = tyConName fam_tc     data_ctxt = DataKindCtxt fam_name+    new_or_data = dataDefnConsNewOrData hs_cons+    is_H98_or_newtype = case hs_cons of+      NewTypeCon{} -> True+      DataTypeCons _ cons -> all isH98 cons+    isH98 (L _ (ConDeclH98 {})) = True+    isH98 _ = False      -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, families (2),-    -- and Note [Implementation of UnliftedDatatypes].+    -- Note [Implementation of UnliftedDatatypes]+    -- and Note [Defaulting result kind of newtype/data family instance].     tc_kind_sig Nothing       = do { unlifted_newtypes  <- xoptM LangExt.UnliftedNewtypes            ; unlifted_datatypes <- xoptM LangExt.UnliftedDatatypes@@ -1031,6 +1054,21 @@ Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcTopSkolemise Examples in indexed-types/should_compile/T12369 +Note [Defaulting result kind of newtype/data family instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is tempting to let `tc_kind_sig` just return `newOpenTypeKind`+even without `-XUnliftedNewtypes`, but we rely on `tc_kind_sig` to+constrain the result kind of a newtype instance to `Type`.+Consider the following example:++  -- no UnliftedNewtypes+  data family D :: k -> k+  newtype instance D a = MkIntD a++`tc_kind_sig` defaulting to `newOpenTypeKind` would result in `D a`+having kind `forall r. TYPE r` instead of `Type`, which would be+rejected validity checking. The same applies to Data Instances.+ Note [Implementing eta reduction for data families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1185,32 +1223,49 @@ by the data instances -- and hence we /can/ specialise T's kind differently in different GADT data constructors. -SHORT SUMMARY: in a data instance decl, it's not clear whether kind+SHORT SUMMARY: In a data instance decl, it's not clear whether kind constraints arising from the data constructors should be considered local to the (GADT) data /constructor/ or should apply to the entire data instance. -DESIGN CHOICE: in data/newtype family instance declarations, we ignore-the /data constructor/ declarations altogether, looking only at the-data instance /header/.+DESIGN CHOICE: In a data/newtype family instance declaration:+* We take account of the data constructors (via `kcConDecls`) for:+  * Haskell-98 style data instance declarations+  * All newtype instance declarations+  For Haskell-98 style declarations, there is no GADT refinement. And for+  GADT-style newtype declarations, no GADT matching is allowed anyway,+  so it's just a syntactic difference from Haskell-98. +* We /ignore/ the data constructors for:+  * GADT-style data instance declarations+  Here, the instance kinds are influenced only by the header.++This choice is implemented by the guarded call to `kcConDecls` in+`tcDataFamInstHeader`.+ Observations:-* This choice is simple to describe, as well as simple to implement.-  For a data/newtype instance decl, the instance kinds are influenced-  /only/ by the header.+* With `UnliftedNewtypes` or `UnliftedDatatypes`, looking at the data+  constructors is necessary to infer the kind of the result type for+  certain cases. Otherwise, additional kind signatures are required.+  Consider the following example in #25611: -* We could treat Haskell-98 style data-instance decls differently, by-  taking the data constructors into account, since there are no GADT-  issues.  But we don't, for simplicity, and because it means you can-  understand the data type instance by looking only at the header.+    data family Fix :: (k -> Type) -> k+    newtype instance Fix f = In { out :: f (Fix f) } -* Newtypes can be declared in GADT syntax, but they can't do GADT-style-  specialisation, so like Haskell-98 definitions we could take the-  data constructors into account.  Again we don't, for the same reason.+  If we are not looking at the data constructors:+  * Without `UnliftedNewtypes`, it is accepted since `Fix f` is defaulted+    to `Type`.+  * But with `UnliftedNewtypes`, `Fix f` is defaulted to `TYPE r` where+    `r` is not scoped over the data constructor. Then the header `Fix f :: TYPE r`+    will fail to kind unify with `f (Fix f) :: Type`. -So for now at least, we keep the simplest choice. See #18891 and !4419-for more discussion of this issue.+  Hence, we need to look at the data constructor to infer `Fix f :: Type`+  for this newtype instance. +This DESIGN CHOICE strikes a balance between well-rounded kind inference+and implementation simplicity. See #25611, #18891, and !4419 for more+discussion of this issue.+ Kind inference for data types (Xie et al) https://arxiv.org/abs/1911.06153 takes a slightly different approach. -}@@ -1338,13 +1393,8 @@              inst_tv_tys = mkTyVarTys inst_tyvars              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys -             is_newtype = isNewTyCon class_tc              dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids-             dfun_spec_prags-                | is_newtype = SpecPrags []-                | otherwise  = SpecPrags spec_inst_prags-                    -- Newtype dfuns just inline unconditionally,-                    -- so don't attempt to specialise them+             dfun_spec_prags = SpecPrags spec_inst_prags               export = ABE { abe_wrap = idHsWrapper                           , abe_poly = dfun_id_w_prags@@ -1377,18 +1427,10 @@ -- the DFunId rather than from the skolem pieces that the typechecker -- is messing with. addDFunPrags dfun_id sc_meth_ids- | is_newtype-  = dfun_id `setIdUnfolding`  mkInlineUnfoldingWithArity defaultSimpleOpts StableSystemSrc 0 con_app-            `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }- | otherwise  = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_bndrs dict_con dict_args            `setInlinePragma` dfunInlinePragma+           -- NB: mkDFunUnfolding takes care of unary classes  where-   con_app    = mkLams dfun_bndrs $-                mkApps (Var (dataConWrapId dict_con)) dict_args-                -- This application will satisfy the Core invariants-                -- from Note [Representation polymorphism invariants] in GHC.Core,-                -- because typeclass method types are never unlifted.    dict_args  = map Type inst_tys ++                 [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] @@ -1397,10 +1439,9 @@    dfun_bndrs  = dfun_tvs ++ ev_ids    clas_tc     = classTyCon clas    dict_con    = tyConSingleDataCon clas_tc-   is_newtype  = isNewTyCon clas_tc  wrapId :: HsWrapper -> Id -> HsExpr GhcTc-wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocA id))+wrapId wrapper id = mkHsWrap wrapper (mkHsVar (noLocA id))  {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1776,7 +1817,7 @@           -> TcM ([Id], LHsBinds GhcTc, Bag Implication)         -- The returned inst_meth_ids all have types starting         --      forall tvs. theta => ...-tcMethods skol_info dfun_id clas tyvars dfun_ev_vars inst_tys+tcMethods _skol_info dfun_id clas tyvars dfun_ev_vars inst_tys                   dfun_ev_binds (spec_inst_prags, prag_fn) op_items                   (InstBindings { ib_binds      = binds                                 , ib_tyvars     = lexical_tvs@@ -1812,7 +1853,7 @@     tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)     tc_item (sel_id, dm_info)       | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn-      = tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys+      = tcMethodBody False clas tyvars dfun_ev_vars inst_tys                      dfun_ev_binds is_derived hs_sig_fn                      spec_inst_prags prags                      sel_id user_bind bndr_loc@@ -1848,7 +1889,8 @@        Just (dm_name, dm_spec) ->         do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name dm_spec-           ; tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys+           ; tcMethodBody (is_vanilla_dm dm_spec)+                          clas tyvars dfun_ev_vars inst_tys                           dfun_ev_binds is_derived hs_sig_fn                           spec_inst_prags inline_prags                           sel_id meth_bind inst_loc }@@ -1889,7 +1931,7 @@         --         -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors,         -- point (D).-        whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $+        whenIsJust (isUnsatisfied (methodExists . unLoc) (classMinimalDef clas)) $         warnUnsatisfiedMinimalDefinition      methodExists meth = isJust (findMethodBind meth binds prag_fn)@@ -1904,6 +1946,12 @@         cls_meth_nms     = map (idName . fst) op_items         mismatched_meths = bind_nms `minusList` cls_meth_nms +    is_vanilla_dm :: DefMethSpec ty -> Bool+    -- See (TRC5) in Note [Tracking redundant constraints]+    --            in GHC.Tc.Solver.Solve+    is_vanilla_dm VanillaDM      = True+    is_vanilla_dm (GenericDM {}) = False+ {- Note [Mismatched class methods and associated type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1973,25 +2021,28 @@ -}  -------------------------tcMethodBody :: SkolemInfoAnon+tcMethodBody :: Bool   -- True <=> This is a vanilla default method+                       -- See (TRC5) in Note [Tracking redundant constraints]+                       --            in GHC.Tc.Solver.Solve              -> Class -> [TcTyVar] -> [EvVar] -> [TcType]              -> TcEvBinds -> Bool              -> HsSigFun              -> [LTcSpecPrag] -> [LSig GhcRn]              -> Id -> LHsBind GhcRn -> SrcSpan              -> TcM (TcId, LHsBind GhcTc, Maybe Implication)-tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys-                     dfun_ev_binds is_derived-                     sig_fn spec_inst_prags prags-                     sel_id (L bind_loc meth_bind) bndr_loc+tcMethodBody is_vanilla_dm clas tyvars dfun_ev_vars inst_tys+             dfun_ev_binds is_derived+             sig_fn spec_inst_prags prags+             sel_id (L bind_loc meth_bind) bndr_loc   = add_meth_ctxt $     do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)+       ; let skol_info = MethSkol meth_name is_vanilla_dm        ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $                                             mkMethIds clas tyvars dfun_ev_vars                                                       inst_tys sel_id         ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc)-                                                        (idName local_meth_id) }+                                              (idName local_meth_id) }                        -- Substitute the local_meth_name for the binder                        -- NB: the binding is always a FunBind @@ -2002,7 +2053,17 @@                 tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)         ; global_meth_id <- addInlinePrags global_meth_id prags-       ; spec_prags     <- tcSpecPrags global_meth_id prags+       ; spec_prags     <- tcExtendIdEnv1 meth_name global_meth_id $+                           -- tcExtendIdEnv1: tricky point: a SPECIALISE pragma in prags+                           -- mentions sel_name but the pragma is really for global_meth_id.+                           -- So we bind sel_name to global_meth_id, just in the pragmas.+                           -- Example:+                           --    instance C [a] where+                           --       op :: forall b. Ord b => b -> a -> a+                           --       {-# SPECIALISE op @Int #-}+                           -- The specialisation is for the `op` for this instance decl, not+                           -- for the global selector-id, of course.+                           tcSpecPrags global_meth_id prags          ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags               export = ABE { abe_poly  = global_meth_id@@ -2021,11 +2082,13 @@          ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }   where+    meth_name = idName sel_id+         -- For instance decls that come from deriving clauses         -- we want to print out the full source code if there's an error         -- because otherwise the user won't see the code at all     add_meth_ctxt thing-      | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing+      | is_derived = addLandmarkErrCtxt (DerivBindCtxt sel_id clas inst_tys) thing       | otherwise  = thing  tcMethodBodyHelp :: HsSigFun -> Id -> TcId@@ -2114,15 +2177,11 @@     poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty     theta         = map idType dfun_ev_vars -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc)+methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) methSigCtxt sel_name sig_ty meth_ty env0   = do { (env1, sig_ty)  <- zonkTidyTcType env0 sig_ty        ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty-       ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))-                      2 (vcat [ text "is more general than its signature in the class"-                              , text "Instance sig:" <+> ppr sig_ty-                              , text "   Class sig:" <+> ppr meth_ty ])-       ; return (env2, msg) }+       ; return (env2, MethSigCtxt sel_name sig_ty meth_ty) }  {- Note [Instance method signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2178,7 +2237,7 @@         --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}         --     These ones have the dfun inside, but [perhaps surprisingly]         --     the correct wrapper.-        -- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind+        -- See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Bind mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me   = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)   where@@ -2272,12 +2331,6 @@     type_to_hs_type = parenthesizeHsType appPrec . noLocA . XHsType  -----------------------derivBindCtxt :: Id -> Class -> [Type ] -> SDoc-derivBindCtxt sel_id clas tys-   = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)-          , nest 2 (text "in a derived instance for"-                    <+> quotes (pprClassPred clas tys) <> colon)-          , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]  warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef@@ -2612,12 +2665,10 @@ ------------------------------ tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty)-  = addErrCtxt (spec_ctxt prag) $+  = addErrCtxt (SpecPragmaCtxt prag) $     do  { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty         ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }-  where-    spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag)  tcSpecInst _  _ = panic "tcSpecInst" @@ -2629,16 +2680,12 @@ ************************************************************************ -} -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc+instDeclCtxt1 :: LHsSigType GhcRn -> ErrCtxtMsg instDeclCtxt1 hs_inst_ty-  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))+  = InstDeclErrCtxt $ Left $ getLHsInstDeclHead hs_inst_ty -instDeclCtxt2 :: Type -> SDoc+instDeclCtxt2 :: Type -> ErrCtxtMsg instDeclCtxt2 dfun_ty-  = inst_decl_ctxt (ppr head_ty)+  = InstDeclErrCtxt $ Right $ head_ty   where     (_,_,head_ty) = tcSplitQuantPredTy dfun_ty--inst_decl_ctxt :: SDoc -> SDoc-inst_decl_ctxt doc = hang (text "In the instance declaration for")-                        2 (quotes doc)
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -37,11 +37,13 @@ import GHC.Tc.TyCl.Build  import GHC.Core.Multiplicity-import GHC.Core.Type ( typeKind, tidyForAllTyBinders, tidyTypes, tidyType, isManyTy, mkTYPEapp )+import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone )+import GHC.Core.TyCo.Tidy( tidyForAllTyBinders, tidyTypes, tidyType ) import GHC.Core.Predicate  import GHC.Types.Name+import GHC.Types.Name.Reader import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Core.PatSyn@@ -85,9 +87,7 @@              -> TcM (LHsBinds GhcTc, TcGblEnv) tcPatSynDecl (L loc psb@(PSB { psb_id = L _ name })) sig_fn prag_fn   = setSrcSpanA loc $-    addErrCtxt (text "In the declaration for pattern synonym"-                <+> quotes (ppr name)) $-    -- See Note [Pattern synonym error recovery]+    addErrCtxt (PatSynDeclCtxt name) $     case sig_fn name of       Nothing                   -> tcInferPatSynDecl psb prag_fn       Just (TcPatSynSig patsig) -> tcCheckPatSynDecl psb patsig prag_fn@@ -154,7 +154,7 @@         ; ((univ_tvs, req_dicts, ev_binds, _), residual)                <- captureConstraints $-                  simplifyInfer tclvl NoRestrictions [] named_taus wanted+                  simplifyInfer TopLevel tclvl NoRestrictions [] named_taus wanted        ; top_ev_binds <- checkNoErrs (simplifyTop residual)        ; addTopEvBinds top_ev_binds $ @@ -184,7 +184,7 @@        ; doNotQuantifyTyVars dvs err_ctx         ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)-       ; rec_fields <- lookupConstructorFields name+       ; rec_fields <- lookupConstructorFields $ noUserRdr name        ; tc_patsyn_finish lname dir is_infix lpat' prag_fn                           (mkTyVarBinders InferredSpec univ_tvs                             , req_theta,  ev_binds, req_dicts)@@ -204,15 +204,15 @@         hetero_tys = [k1, k2, ty1, ty2]   = case r of       ReprEq | is_homo-             -> Just ( mkClassPred coercibleClass    homo_tys-                     , evDataConApp coercibleDataCon homo_tys eq_con_args )+             -> Just ( mkClassPred coercibleClass homo_tys+                     , evDictApp   coercibleClass homo_tys eq_con_args )              | otherwise -> Nothing       NomEq  | is_homo-             -> Just ( mkClassPred eqClass    homo_tys-                     , evDataConApp eqDataCon homo_tys eq_con_args )+             -> Just ( mkClassPred eqClass homo_tys+                     , evDictApp   eqClass homo_tys eq_con_args )              | otherwise-             -> Just ( mkClassPred heqClass    hetero_tys-                     , evDataConApp heqDataCon hetero_tys eq_con_args )+             -> Just ( mkClassPred heqClass hetero_tys+                     , evDictApp   heqClass hetero_tys eq_con_args )    | otherwise   = Just (pred, EvExpr (evId ev_id))@@ -294,7 +294,7 @@   $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a  and that is bad because (a ~# Maybe b) is not a predicate type-(see Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep+(see Note [Types for coercions, predicates, and evidence] in GHC.Core.Predicate and is not implicitly instantiated.  So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and@@ -454,7 +454,7 @@         ; traceTc "tcCheckPatSynDecl }" $ ppr name -       ; rec_fields <- lookupConstructorFields name+       ; rec_fields <- lookupConstructorFields $ noUserRdr name        ; tc_patsyn_finish lname dir is_infix lpat' prag_fn                           (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts)                           (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts)@@ -642,7 +642,7 @@                      -> ([Name], Bool) collectPatSynArgInfo details =   case details of-    PrefixCon _ names    -> (map unLoc names, False)+    PrefixCon names      -> (map unLoc names, False)     InfixCon name1 name2 -> (map unLoc [name1, name2], True)     RecCon names         -> (map (unLoc . recordPatSynPatVar) names, False) @@ -954,7 +954,7 @@                                     (EmptyLocalBinds noExtField)      args = case details of-              PrefixCon _ args   -> args+              PrefixCon args     -> args               InfixCon arg1 arg2 -> [arg1, arg2]               RecCon args        -> map recordPatSynPatVar args @@ -1000,7 +1000,8 @@     lhsVars = mkNameSet (map unLoc args)      -- Make a prefix con for prefix and infix patterns for simplicity-    mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]+    mkPrefixConExpr :: LocatedN (WithUserRdr Name)+                    -> [LPat GhcRn]                     -> Either PatSynInvalidRhsReason (HsExpr GhcRn)     mkPrefixConExpr lcon@(L loc _) pats       = do { exprs <- mapM go pats@@ -1008,7 +1009,8 @@            ; return (unLoc $ mkHsApps con exprs)            } -    mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn)+    mkRecordConExpr :: LocatedN (WithUserRdr Name)+                    -> HsRecFields GhcRn (LPat GhcRn)                     -> Either PatSynInvalidRhsReason (HsExpr GhcRn)     mkRecordConExpr con (HsRecFields x fields dd)       = do { exprFields <- mapM go' fields@@ -1023,7 +1025,7 @@     go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)     go1 (ConPat NoExtField con info)       = case info of-          PrefixCon _ ps -> mkPrefixConExpr con ps+          PrefixCon ps   -> mkPrefixConExpr con ps           InfixCon l r   -> mkPrefixConExpr con [l,r]           RecCon fields  -> mkRecordConExpr con fields @@ -1032,7 +1034,7 @@      go1 (VarPat _ (L l var))         | var `elemNameSet` lhsVars-        = return $ HsVar noExtField (L l var)+        = return $ mkHsVar (L l var)         | otherwise         = Left (PatSynUnboundVar var)     go1 (ParPat _ pat) = fmap (HsPar noExtField) (go pat)@@ -1248,7 +1250,7 @@     go1 _                   = empty      goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])-    goConDetails (PrefixCon _ ps) = mergeMany . map go $ ps+    goConDetails (PrefixCon ps)   = mergeMany . map go $ ps     goConDetails (InfixCon p1 p2) = go p1 `merge` go p2     goConDetails (RecCon HsRecFields{ rec_flds = flds })       = mergeMany . map goRecFd $ flds
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1999@@ -736,13 +734,14 @@ updateRoleEnv name n role   = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((),          case lookupNameEnv role_env name of-           Nothing -> pprPanic "updateRoleEnv" (ppr name)-           Just roles -> let (before, old_role : after) = splitAt n roles in-                         if role `ltRole` old_role+           Just roles+             | (before, old_role : after) <- splitAt n roles+             ->          if role `ltRole` old_role                          then let roles' = before ++ role : after                                   role_env' = extendNameEnv role_env name roles' in                               RIS { role_env = role_env', update = True }-                         else state )+                         else state+           _ -> pprPanic "updateRoleEnv" (ppr name))   {- *********************************************************************@@ -802,14 +801,6 @@      --     (#13998)  {--************************************************************************-*                                                                      *-                Building record selectors-*                                                                      *-************************************************************************--}--{- Note [Default method Ids and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (#4169):@@ -835,10 +826,25 @@ ************************************************************************ -} +{- Note [Record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Record selectors are injected as ordianry functions definitions, very+early in the pipeline.++* `mkRecSelBinds` produces /un-typechecked/ bindings, rather like 'deriving'+   This makes life easier, because the later type checking will add+   all necessary type abstractions and applications; and handling for+   UNPACK pragmas etc++* Record selectors are not treated as "implicit".  See+  See Note [Implicit TyThings] in GHC.Types.TyThing and+      Note [Injecting implicit bindings] in GHC.CoreToStg.AddImplicitBinds+-}+ tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs   = tcExtendGlobalValEnv [sel_id | (L _ (XSig (IdSig sel_id))) <- sigs] $-    do { (rec_sel_binds, _, tcg_env) <- discardWarnings $+    do { (rec_sel_binds, tcg_env) <- discardWarnings $                                        -- See Note [Impredicative record selectors]                                        setXOptM LangExt.ImpredicativeTypes $                                        tcValBinds TopLevel binds sigs getGblEnv@@ -850,9 +856,7 @@     binds = [(NonRecursive, [bind]) | (_, bind) <- sel_bind_prs]  mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]--- NB We produce *un-typechecked* bindings, rather like 'deriving'---    This makes life easier, because the later type checking will add---    all necessary type abstractions and applications+-- See Note [Record selectors] mkRecSelBinds tycons   = map mkRecSelBind [ (tc,fld) | tc <- tycons                                 , fld <- tyConFieldLabels tc ]@@ -881,15 +885,17 @@     sel_id = mkExportedLocalId rec_details sel_name sel_ty      -- Find a representative constructor, con1-    cons_partitioned@(cons_w_field, _) = conLikesWithFields all_cons [lbl]+    rec_sel_info@(RSI { rsi_def = cons_w_field })+         = conLikesRecSelInfo all_cons [lbl]     con1 = assert (not (null cons_w_field)) $ head cons_w_field      -- Construct the IdDetails     rec_details = RecSelId { sel_tycon      = idDetails                            , sel_naughty    = is_naughty                            , sel_fieldLabel = fl-                           , sel_cons       = cons_partitioned }-                               -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc+                           , sel_cons       = rec_sel_info }+                             -- See (IRS1) in Note [Detecting incomplete record selectors]+                             -- in GHC.HsToCore.Pmc       -- Selector type; Note [Polymorphic selectors]@@ -916,7 +922,7 @@                                                   -- A slight hack!      sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]-           | otherwise  = mkForAllTys (tyVarSpecToBinders sel_tvbs) $+           | otherwise  = mkForAllTys sel_tvbs $                           -- Urgh! See Note [The stupid context] in GHC.Core.DataCon                           mkPhiTy (conLikeStupidTheta con1) $                           -- req_theta is empty for normal DataCon@@ -936,8 +942,10 @@              | otherwise =  map mk_match cons_w_field ++ deflt     mk_match con = mkSimpleMatch match_ctxt                                  (L (l2l loc') [L loc' (mk_sel_pat con)])-                                 (L loc' (HsVar noExtField (L locn field_var)))-    mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields)+                                 (L loc' (mkHsVar (L locn field_var)))+    mk_sel_pat con =+      let con_lname = L locn (noUserRdr (getName con))+      in ConPat NoExtField con_lname (RecCon rec_fields)     rec_fields = HsRecFields { rec_ext = noExtField, rec_flds = [rec_field], rec_dotdot = Nothing }     rec_field  = noLocA (HsFieldBind                         { hfbAnn = noAnn
− compiler/GHC/Tc/Types/EvTerm.hs 
@@ -1,72 +0,0 @@---- (those who have too heavy dependencies for GHC.Tc.Types.Evidence)-module GHC.Tc.Types.EvTerm-    ( evDelayedError, evCallStack )-where--import GHC.Prelude--import GHC.Driver.DynFlags--import GHC.Tc.Types.Evidence--import GHC.Unit--import GHC.Builtin.Names-import GHC.Builtin.Types ( unitTy )--import GHC.Core.Type-import GHC.Core-import GHC.Core.Make-import GHC.Core.Utils--import GHC.Types.SrcLoc-import GHC.Types.TyThing---- Used with Opt_DeferTypeErrors--- See Note [Deferring coercion errors to runtime]--- in GHC.Tc.Solver-evDelayedError :: Type -> String -> EvTerm-evDelayedError ty msg-  = EvExpr $-    let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg-    in mkWildCase fail_expr (unrestricted unitTy) ty []-       -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils-       -- c.f. mkErrorAppDs in GHC.HsToCore.Utils---- Dictionary for CallStack implicit parameters-evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>-    EvCallStack -> m EvExpr--- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-evCallStack EvCsEmpty =-  Var <$> lookupId emptyCallStackName-evCallStack (EvCsPushCall fs loc tm) = do-  df            <- getDynFlags-  let platform = targetPlatform df-  m             <- getModule-  srcLocDataCon <- lookupDataCon srcLocDataConName-  let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>-               sequence [ mkStringExprFS (unitFS $ moduleUnit m)-                        , mkStringExprFS (moduleNameFS $ moduleName m)-                        , mkStringExprFS (srcSpanFile l)-                        , return $ mkIntExprInt platform (srcSpanStartLine l)-                        , return $ mkIntExprInt platform (srcSpanStartCol l)-                        , return $ mkIntExprInt platform (srcSpanEndLine l)-                        , return $ mkIntExprInt platform (srcSpanEndCol l)-                        ]--  pushCSVar <- lookupId pushCallStackName-  let pushCS name loc rest =-        mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]--  let mkPush name loc tm = do-        nameExpr <- mkStringExprFS name-        locExpr <- mkSrcLoc loc-        -- at this point tm :: IP sym CallStack-        -- but we need the actual CallStack to pass to pushCS,-        -- so we use unwrapIP to strip the dictionary wrapper-        -- See Note [Overview of implicit CallStacks]-        let ip_co = unwrapIP (exprType tm)-        return (pushCS nameExpr locExpr (Cast tm ip_co))--  mkPush fs loc tm
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -1,4 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields    #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables      #-} {-# LANGUAGE TypeFamilies             #-}@@ -97,7 +98,7 @@     -- implementation cases.     checkBootDeclM Hsig sig_thing real_thing     real_fixity <- lookupFixityRn name-    let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of+    let sig_fixity = case mi_fix_fn sig_iface (occName name) of                         Nothing -> defaultFixity                         Just f -> f     when (real_fixity /= sig_fixity) $@@ -221,7 +222,8 @@     (tclvl,cts) <- pushTcLevelM $ do        given_ids <- mapM newEvVar inst_theta        let given_loc = mkGivenLoc topTcLevel skol_info (mkCtLocEnv lcl_env)-           givens = [ CtGiven { ctev_pred = idType given_id+           givens = [ CtGiven $+                      GivenCt { ctev_pred = idType given_id                               -- Doesn't matter, make something up                               , ctev_evar = given_id                               , ctev_loc  = given_loc  }@@ -297,14 +299,14 @@ -- than a transitive closure done here) all the free holes are still reachable. implicitRequirementsShallow   :: HscEnv-  -> [(PkgQual, Located ModuleName)]+  -> [(ImportLevel, PkgQual, Located ModuleName)]   -> IO ([ModuleName], [InstantiatedUnit]) implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports  where   mhome_unit = hsc_home_unit_maybe hsc_env    go acc [] = pure acc-  go (accL, accR) ((mb_pkg, L _ imp):imports) = do+  go (accL, accR) ((_stage, mb_pkg, L _ imp):imports) = do     found <- findImportedModule hsc_env imp mb_pkg     let acc' = case found of           Found _ mod | notHomeModuleMaybe mhome_unit mod ->@@ -484,15 +486,6 @@ -- logically "implicit" entities are defined indirectly in an interface -- file.  #13151 gives a proposal to make these *truly* implicit. -merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc-merge_msg mod_name [] =-    text "while checking the local signature" <+> ppr mod_name <+>-    text "for consistency"-merge_msg mod_name reqs =-  hang (text "while merging the signatures from" <> colon)-   2 (vcat [ bullet <+> ppr req | req <- reqs ] $$-      bullet <+> text "...and the local signature for" <+> ppr mod_name)- -- | Given a local 'ModIface', merge all inherited requirements -- from 'requirementMerges' into this signature, producing -- a final 'TcGblEnv' that matches the local signature and@@ -542,7 +535,7 @@     -- we are going to merge in.     let reqs = requirementMerges unit_state mod_name -    addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do+    addErrCtxt (MergeSignaturesCtxt unit_state mod_name reqs) $ do      -- STEP 2: Read in the RAW forms of all of these interfaces     ireq_ifaces0 <- liftIO $ forM reqs $ \(Module iuid mod_name) -> do@@ -641,7 +634,8 @@                                             is_pkg_qual = NoPkgQual,                                             is_qual     = False,                                             is_isboot   = NotBoot,-                                            is_dloc     = locA loc+                                            is_dloc     = locA loc,+                                            is_level    = NormalLevel                                           } ImpAll                                 rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1                             setGblEnv tcg_env {@@ -651,7 +645,7 @@                                     emptyImportAvails                                     (tcg_semantic_mod tcg_env)                         case mb_r of-                            Just (_, as2, _) -> return (thinModIface as2 ireq_iface, as2)+                            Just (_, _, as2, _) -> return (thinModIface as2 ireq_iface, as2)                             Nothing -> addMessages msgs >> failM                     -- We can't thin signatures from non-signature packages                     _ -> return (ireq_iface, as1)@@ -708,8 +702,9 @@      -- Make sure we didn't refer to anything that doesn't actually exist     -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()-    (mb_lies, _, _) <- exports_from_avail mb_exports rdr_env-                        (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)+    (mb_lies, exp_dflts, _, _) <-+      exports_from_avail mb_exports rdr_env+          (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)      {- -- NB: This is commented out, because warns above is disabled.     -- If you tried to explicitly export an identifier that has a warning@@ -729,8 +724,7 @@     failIfErrsM      -- Save the exports-    let drop_defaults (spans, _defaults, avails) = (spans, avails)-    setGblEnv tcg_env { tcg_rn_exports = map drop_defaults <$> mb_lies } $ do+    setGblEnv tcg_env { tcg_rn_exports = mb_lies, tcg_default_exports = exp_dflts } $ do     tcg_env <- getGblEnv      let home_unit = hsc_home_unit hsc_env@@ -859,7 +853,7 @@                 if outer_mod == mi_module iface                     -- Don't add ourselves!                     then tcg_merged tcg_env-                    else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env+                    else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env             }      -- Note [Signature merging DFuns]@@ -918,13 +912,6 @@ exportOccs :: [AvailInfo] -> [OccName] exportOccs = concatMap (map nameOccName . availNames) -impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc-impl_msg unit_state impl_mod (Module req_uid req_mod_name)-   = pprWithUnitState unit_state $-      text "While checking that" <+> quotes (ppr impl_mod) <+>-      text "implements signature" <+> quotes (ppr req_mod_name) <+>-      text "in" <+> quotes (ppr req_uid) <> dot- -- | Check if module implements a signature.  (The signature is -- always un-hashed, which is why its components are specified -- explicitly.)@@ -934,7 +921,7 @@   let unit_state = hsc_units hsc_env       home_unit  = hsc_home_unit hsc_env       other_home_units = hsc_all_home_unit_ids hsc_env-  addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do+  addErrCtxt (CheckImplementsCtxt unit_state impl_mod req_mod) $ do     let insts = instUnitInsts uid      -- STEP 1: Load the implementing interface, and make a RdrEnv
compiler/GHC/Tc/Utils/Concrete.hs view
@@ -19,39 +19,35 @@ import GHC.Prelude  import GHC.Builtin.Names       ( unsafeCoercePrimName )-import GHC.Builtin.Types       ( liftedTypeKindTyCon, unliftedTypeKindTyCon )+import GHC.Builtin.Types -import GHC.Core.Coercion       ( coToMCo, mkCastTyMCo-                               , mkGReflRightMCo, mkNomReflCo )-import GHC.Core.TyCo.Rep       ( Type(..), MCoercion(..) )-import GHC.Core.TyCon          ( isConcreteTyCon )-import GHC.Core.Type           ( isConcreteType, typeKind, mkFunTy)+import GHC.Core.Coercion+import GHC.Core.TyCo.Rep+import GHC.Core.Type -import GHC.Tc.Types.Constraint ( NotConcreteError(..), NotConcreteReason(..) )-import GHC.Tc.Types.Evidence   ( Role(..), TcCoercionN, TcMCoercionN )+import GHC.Data.Bag++import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.TcMType+import {-# SOURCE #-} GHC.Tc.Utils.Unify  import GHC.Types.Basic         ( TypeOrKind(KindLevel) ) import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Types.Name import GHC.Types.Name.Env-import GHC.Types.Var           ( tyVarKind, tyVarName )+import GHC.Types.Var  import GHC.Utils.Misc          ( HasDebugCallStack ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString     ( FastString, fsLit ) - import Control.Monad      ( void ) import Data.Functor       ( ($>) )-import Data.List.NonEmpty ( NonEmpty((:|)) ) -import Control.Monad.Trans.Class      ( lift )-import Control.Monad.Trans.Writer.CPS ( WriterT, runWriterT, tell )  {- Note [Concrete overview] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -221,7 +217,6 @@ only be unified with a concrete type (in the sense of Note [Concrete types]).  INVARIANT: the kind of a concrete metavariable is concrete.- This invariant is upheld at the time of creation of a new concrete metavariable.  Concrete metavariables are useful for representation-polymorphism checks:@@ -632,7 +627,7 @@                         -- That is, @ty'@ has a syntactically fixed RuntimeRep                         -- in the sense of Note [Fixed RuntimeRep]. hasFixedRuntimeRep frr_ctxt ty =-  checkFRR_with (unifyConcrete (fsLit "cx") . ConcreteFRR) frr_ctxt ty+  checkFRR_with (fmap (fmap coToMCo) . unifyConcrete_kind (fsLit "cx") . ConcreteFRR) frr_ctxt ty  -- | Like 'hasFixedRuntimeRep', but we perform an eager syntactic check. --@@ -675,7 +670,7 @@                   -- ^ Returns @(co, frr_ty)@ with @co :: ty ~# frr_ty@                   -- and @frr_@ty has a fixed 'RuntimeRep'. checkFRR_with check_kind frr_ctxt ty-  = do { th_stage <- getStage+  = do { th_lvl <- getThLevel        ; if           -- Shortcut: check for 'Type' and 'UnliftedType' type synonyms.           | TyConApp tc [] <- ki@@ -683,7 +678,7 @@           -> return refl            -- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep].-          | Brack _ (TcPending {}) <- th_stage+          | TypedBrack {} <- th_lvl           -> return refl            -- Otherwise: ensure that the kind 'ki' of 'ty' is concrete.@@ -700,228 +695,88 @@     frr_orig :: FixedRuntimeRepOrigin     frr_orig = FixedRuntimeRepOrigin { frr_type = ty, frr_context = frr_ctxt } --- | Ensure that the given type @ty@ can unify with a concrete type,+-- | Ensure that the given kind @ki@ can unify with a concrete type, -- in the sense of Note [Concrete types]. ----- Returns a coercion @co :: ty ~# conc_ty@, where @conc_ty@ is+-- Returns a coercion @co :: ki ~# conc_ki@, where @conc_ki@ is -- concrete. ----- If the type is already syntactically concrete, this+-- If the kind is already syntactically concrete, this -- immediately returns a reflexive coercion. Otherwise, -- it creates a new concrete metavariable @concrete_tv@--- and emits an equality constraint @ty ~# concrete_tv@,+-- and emits an equality constraint @ki ~# concrete_tv@, -- to be handled by the constraint solver. --+-- Precondition: @ki@ must be of the form @TYPE rep@ or @CONSTRAINT rep@.+unifyConcrete_kind :: HasDebugCallStack+                   => FastString -- ^ name to use when creating concrete metavariables+                   -> ConcreteTvOrigin+                   -> TcKind+                   -> TcM TcCoercionN+unifyConcrete_kind occ_fs conc_orig ki+  | Just (torc, rep) <- sORTKind_maybe ki+  = do { let tc = case torc of+                    TypeLike -> tYPETyCon+                    ConstraintLike -> cONSTRAINTTyCon+       ; rep_co <- unifyConcrete occ_fs conc_orig rep+       ; return $ mkTyConAppCo Nominal tc [rep_co] }+  | otherwise+  = pprPanic "unifyConcrete_kind: kind is not of the form 'TYPE rep' or 'CONSTRAINT rep'" $+      ppr ki <+> dcolon <+> ppr (typeKind ki)+++-- | Ensure the given type can be unified with+-- a concrete type, in the sense of Note [Concrete types].+--+-- Returns a coercion @co :: ty ~# conc_ty@, where @conc_ty@ is+-- concrete.+--+-- If the type is already syntactically concrete, this+-- immediately returns a reflexive coercion.+-- Otherwise, it will create new concrete metavariables and emit+-- new Wanted equality constraints, to be handled by the constraint solver.+-- -- Invariant: the kind of the supplied type must be concrete. -- -- We assume the provided type is already at the kind-level -- (this only matters for error messages).-unifyConcrete :: HasDebugCallStack-              => FastString -> ConcreteTvOrigin -> TcType -> TcM TcMCoercionN+unifyConcrete :: FastString -> ConcreteTvOrigin -> TcType -> TcM TcCoercionN unifyConcrete occ_fs conc_orig ty-  = do { (ty, errs) <- makeTypeConcrete conc_orig ty-       ; case errs of-           -- We were able to make the type fully concrete.-         { [] -> return MRefl-           -- The type could not be made concrete; perhaps it contains-           -- a skolem type variable, a type family application, ...-           ---           -- Create a new ConcreteTv metavariable @concrete_tv@-           -- and unify @ty ~# concrete_tv@.-         ; _  ->-    do { conc_tv <- newConcreteTyVar conc_orig occ_fs ki-           -- NB: newConcreteTyVar asserts that 'ki' is concrete.-       ; coToMCo <$> emitWantedEq orig KindLevel Nominal ty (mkTyVarTy conc_tv) } } }-  where-    ki :: TcKind-    ki = typeKind ty-    orig :: CtOrigin-    orig = case conc_orig of-      ConcreteFRR frr_orig -> FRROrigin frr_orig+  = do { (co, cts) <- makeTypeConcrete occ_fs conc_orig ty+       ; emitSimples cts+       ; return co } --- | Ensure that the given type is concrete.+-- | Ensure that the given kind @ki@ is concrete. -- -- This is an eager syntactic check, and never defers--- any work to the constraint solver.------ Invariant: the kind of the supplied type must be concrete.--- Invariant: the output type is equal to the input type,---            up to zonking.+-- any work to the constraint solver. However,+-- it may perform unification. ----- We assume the provided type is already at the kind-level--- (this only matters for error messages).+-- Invariant: the output type is equal to the input type, up to zonking. ensureConcrete :: HasDebugCallStack                => FixedRuntimeRepOrigin-               -> TcType-               -> TcM TcType-ensureConcrete frr_orig ty-  = do { traceTc "ensureConcrete {" (ppr frr_orig $$ ppr ty)-       ; (ty', errs) <- makeTypeConcrete conc_orig ty-       ; case errs of-          { err:errs ->-              do { traceTc "ensureConcrete } failure" $-                     vcat [ text "ty:" <+> ppr ty-                          , text "ty':" <+> ppr ty' ]+               -> TcKind+               -> TcM TcKind+ensureConcrete frr_orig ki+  = do { (co, cts) <- makeTypeConcrete (fsLit "cx") conc_orig ki+       ; let trace_msg = vcat [ text "ty: " <+> ppr ki+                              , text "co:" <+> ppr co ]+       ; if isEmptyBag cts+         then traceTc "ensureConcrete } success" trace_msg+         else do { traceTc "ensureConcrete } failure" trace_msg                  ; loc <- getCtLocM (FRROrigin frr_orig) (Just KindLevel)                  ; emitNotConcreteError $                      NCE_FRR                        { nce_loc = loc-                       , nce_frr_origin = frr_orig-                       , nce_reasons = err :| errs }-                 }-          ; [] ->-              traceTc "ensureConcrete } success" $-                vcat [ text "ty: " <+> ppr ty-                     , text "ty':" <+> ppr ty' ] }-        ; return ty' }+                       , nce_frr_origin = frr_orig }+             }+       ; return $ coercionRKind co }   where     conc_orig :: ConcreteTvOrigin     conc_orig = ConcreteFRR frr_orig  {-*********************************************************************** %*                                                                      *-                    Making a type concrete-%*                                                                      *-%************************************************************************--Note [Unifying concrete metavariables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Unifying concrete metavariables (as defined in Note [ConcreteTv]) is not-an all-or-nothing affair as it is for other sorts of metavariables.--Consider the following unification problem in which all metavariables-are unfilled (and ignoring any TcLevel considerations):--  alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])--We can't immediately unify `alpha` with the RHS, because the RHS is not-a concrete type (in the sense of Note [Concrete types]). Instead, we-proceed as follows:--  - create a fresh concrete metavariable variable `gamma'[conc]`,-  - write gamma[tau] := gamma'[conc],-  - write alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma'[conc] ]).--Thus, in general, to unify `alpha[conc] ~# rhs`, we first try to turn-`rhs` into a concrete type (see the 'makeTypeConcrete' function).-If this succeeds, resulting in a concrete type `rhs'`, we simply fill-`alpha[conc] := rhs'`. If it fails, then syntactic unification fails.--Example 1:--    alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])--  We proceed by filling metavariables:--    gamma[tau] := gamma[conc]-    alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma[conc] ])--  This successfully unifies alpha.--Example 2:--  For a type family `F :: Type -> Type`:--    delta[conc] ~# TYPE (SumRep '[ zeta[tau], a[sk], F omega[tau] ])--  We write zeta[tau] := zeta[conc], and then fail, providing the following-  two reasons:--    - `a[sk]` is not a concrete type variable, so the overall type-      cannot be concrete-    - `F` is not a concrete type constructor, in the sense of-       Note [Concrete types]. So we keep it as is; in particular,-       we /should not/ try to make its argument `omega[tau]` into-       a ConcreteTv.--  Note that making zeta concrete allows us to propagate information.-  For example, after more typechecking, we might try to unify-  `zeta ~# rr[sk]`. If we made zeta a ConcreteTv, we will report-  this unsolved equality using the 'ConcreteTvOrigin' stored in zeta[conc].-  This allows us to report ALL the problems in a representation-polymorphism-  check (instead of only a non-empty subset).--}---- | Try to turn the provided type into a concrete type, by ensuring--- unfilled metavariables are appropriately marked as concrete.------ Returns a zonked type which is "as concrete as possible", and--- a list of problems encountered when trying to make it concrete.------ INVARIANT: the returned type is equal to the input type, up to zonking.--- INVARIANT: if this function returns an empty list of 'NotConcreteReasons',--- then the returned type is concrete, in the sense of Note [Concrete types].-makeTypeConcrete :: ConcreteTvOrigin -> TcType -> TcM (TcType, [NotConcreteReason])--- TODO: it could be worthwhile to return enough information to continue solving.--- Consider unifying `alpha[conc] ~# TupleRep '[ beta[tau], F Int ]` for--- a type family 'F'.--- This function will concretise `beta[tau] := beta[conc]` and return--- that `TupleRep '[ beta[conc], F Int ]` is not concrete because of the--- type family application `F Int`. But we could decompose by setting--- alpha := TupleRep '[ beta, gamma[conc] ] and emitting `[W] gamma[conc] ~ F Int`.-makeTypeConcrete conc_orig ty =-  do { res@(ty', _) <- runWriterT $ go ty-     ; traceTc "makeTypeConcrete" $-        vcat [ text "ty:" <+> ppr ty-             , text "ty':" <+> ppr ty' ]-     ; return res }-  where-    go :: TcType -> WriterT [NotConcreteReason] TcM TcType-    go ty-      | Just ty <- coreView ty-      = go ty-      | isConcreteType ty-      = pure ty-    go ty@(TyVarTy tv) -- not a ConcreteTv (already handled above)-      = do { mb_filled <- lift $ isFilledMetaTyVar_maybe tv-           ; case mb_filled of-           { Just ty -> go ty-           ; Nothing-               | isMetaTyVar tv-               , TauTv <- metaTyVarInfo tv-               -> -- Change the MetaInfo to ConcreteTv, but retain the TcLevel-               do { kind <- go (tyVarKind tv)-                  ; let occ_fs = occNameFS (getOccName tv)-                        -- occ_fs: preserve the occurrence name of the original tyvar-                        -- This helps in error messages-                  ; lift $-                    do { conc_tv <- setTcLevel (tcTyVarLevel tv) $-                                    newConcreteTyVar conc_orig occ_fs kind-                       ; let conc_ty = mkTyVarTy conc_tv-                       ; liftZonkM $ writeMetaTyVar tv conc_ty-                       ; return conc_ty } }-               | otherwise-               -- Don't attempt to make other type variables concrete-               -- (e.g. SkolemTv, TyVarTv, CycleBreakerTv, RuntimeUnkTv).-               -> bale_out ty (NonConcretisableTyVar tv) } }-    go ty@(TyConApp tc tys)-      | isConcreteTyCon tc-      = mkTyConApp tc <$> mapM go tys-      | otherwise-      = bale_out ty (NonConcreteTyCon tc tys)-    go (FunTy af w ty1 ty2)-      = do { w <- go w-           ; ty1 <- go ty1-           ; ty2 <- go ty2-           ; return $ mkFunTy af w ty1 ty2 }-    go (AppTy ty1 ty2)-      = do { ty1 <- go ty1-           ; ty2 <- go ty2-           ; return $ mkAppTy ty1 ty2 }-    go ty@(LitTy {})-      = return ty-    go ty@(CastTy cast_ty kco)-      = bale_out ty (ContainsCast cast_ty kco)-    go ty@(ForAllTy tcv body)-      = bale_out ty (ContainsForall tcv body)-    go ty@(CoercionTy co)-      = bale_out ty (ContainsCoercionTy co)--    bale_out :: TcType -> NotConcreteReason -> WriterT [NotConcreteReason] TcM TcType-    bale_out ty reason = do { tell [reason]; return ty }--{-***********************************************************************-%*                                                                      *                    Concrete type variables of Ids %*                                                                      * %**********************************************************************-}@@ -948,7 +803,7 @@   = mkNameEnv     [(tyVarName a_rep, ConcreteFRR $ FixedRuntimeRepOrigin (mkTyVarTy a)                                    $ FRRRepPolyId unsafeCoercePrimName RepPolyFunction-                                   $ Argument 1 Top)]+                                   $ mkArgPos 1 Top)]    | otherwise   = idDetailsConcreteTvs $ idDetails id
compiler/GHC/Tc/Utils/Env.hs view
@@ -29,7 +29,7 @@         tcLookupLocatedClass, tcLookupAxiom,         lookupGlobal, lookupGlobal_maybe,         addTypecheckedBinds,-        failIllegalTyCon, failIllegalTyVal,+        failIllegalTyCon, failIllegalTyVar,          -- Local environment         tcExtendKindEnv, tcExtendKindEnvList,@@ -60,9 +60,9 @@         tcGetDefaultTys,          -- Template Haskell stuff-        StageCheckReason(..),-        checkWellStaged, tcMetaTy, thLevel,-        topIdLvl, isBrackStage,+        LevelCheckReason(..),+        tcMetaTy, thLevelIndex,+        isBrackLevel,          -- New Ids         newDFunName,@@ -93,7 +93,6 @@ import GHC.Tc.Utils.TcType import {-# SOURCE #-} GHC.Tc.Utils.TcMType ( tcCheckUsage ) import GHC.Tc.Types.LclEnv-import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper, (<.>))  import GHC.Core.InstEnv import GHC.Core.DataCon ( DataCon, dataConTyCon, flSelector )@@ -109,7 +108,7 @@ import GHC.Unit.Module import GHC.Unit.Module.ModDetails import GHC.Unit.Home-import GHC.Unit.Env+import GHC.Unit.Home.Graph import GHC.Unit.Home.ModInfo import GHC.Unit.External @@ -120,7 +119,7 @@  import GHC.Data.FastString import GHC.Data.List.SetOps-import GHC.Data.Maybe( MaybeErr(..), orElse )+import GHC.Data.Maybe( MaybeErr(..), orElse, maybeToList, fromMaybe )  import GHC.Types.SrcLoc import GHC.Types.Basic hiding( SuccessFlag(..) )@@ -129,8 +128,8 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env-import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults(..),-                              defaultEnv, emptyDefaultEnv, lookupDefaultEnv, unitDefaultEnv )+import GHC.Types.DefaultEnv+import GHC.Types.Error import GHC.Types.Id import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name.Reader@@ -138,12 +137,15 @@ import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt +import GHC.Iface.Errors.Types+import GHC.Rename.Unbound ( unknownNameSuggestions )+import GHC.Tc.Errors.Types.PromotionErr+import {-# SOURCE #-} GHC.Tc.Errors.Hole (getHoleFitDispConfig)++import Control.Monad import Data.IORef import Data.List          ( intercalate )-import Control.Monad-import GHC.Iface.Errors.Types-import GHC.Types.Error-import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )+import qualified Data.List.NonEmpty as NE  {- ********************************************************************* *                                                                      *@@ -279,12 +281,12 @@         AConLike (PatSynCon ps) -> return ps         _                       -> wrongThingErr WrongThingPatSyn (AGlobal thing) name -tcLookupConLike :: Name -> TcM ConLike-tcLookupConLike name = do+tcLookupConLike :: WithUserRdr Name -> TcM ConLike+tcLookupConLike qname@(WithUserRdr _ name) = do     thing <- tcLookupGlobal name     case thing of         AConLike cl -> return cl-        ATyCon  {}  -> failIllegalTyCon WL_Constructor name+        ATyCon  {}  -> failIllegalTyCon WL_ConLike qname         _           -> wrongThingErr WrongThingConLike (AGlobal thing) name  tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent@@ -354,9 +356,9 @@  lookupClsDefault :: HomeUnitGraph -> ModuleEnv DefaultEnv -> Module -> IO (Maybe DefaultEnv) lookupClsDefault hug module_env_defaults mod =-  case lookupHugByModule mod hug of-    Just hm -> pure $ Just $ md_defaults $ hm_details hm-    Nothing -> pure $ lookupModuleEnv module_env_defaults mod+  lookupHugByModule mod hug >>= \case+             Just hm -> pure $ Just $ md_defaults $ hm_details hm+             Nothing -> pure $ lookupModuleEnv module_env_defaults mod  tcGetInstEnvs :: TcM InstEnvs -- Gets both the external-package inst-env@@ -371,46 +373,98 @@     lookupThing = tcLookupGlobal  -- Illegal term-level use of type things-failIllegalTyCon :: WhatLooking -> Name -> TcM a-failIllegalTyVal :: Name -> TcM a-(failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar)+failIllegalTyCon :: WhatLooking -> WithUserRdr Name -> TcM a+failIllegalTyVar :: WithUserRdr Name -> TcM a+(failIllegalTyCon, failIllegalTyVar) = (fail_tycon, fail_tyvar)   where-    fail_tycon what_looking tc_nm = do+    fail_tycon what_looking (WithUserRdr rdr tc_nm) = do       gre <- getGlobalRdrEnv       let mb_gre = lookupGRE_Name gre tc_nm-          pprov = case mb_gre of-                      Just gre -> nest 2 (pprNameProvenance gre)-                      Nothing  -> empty           err = case greInfo <$> mb_gre of             Just (IAmTyCon ClassFlavour) -> ClassTE             _ -> TyConTE-      fail_with_msg what_looking dataName tc_nm pprov err+      fail_with_msg what_looking dataName rdr tc_nm (TermLevelUseGRE <$> mb_gre) err -    fail_tyvar nm =-      let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))-      in fail_with_msg WL_Anything varName nm pprov TyVarTE+    fail_tyvar (WithUserRdr rdr nm) =+      fail_with_msg WL_Term varName rdr nm (Just TermLevelUseTyVar) TyVarTE -    fail_with_msg what_looking whatName nm pprov err = do-      (import_errs, hints) <- get_suggestions what_looking whatName nm+    fail_with_msg what_looking whatName rdr nm pprov err = do+      required_type_arguments <- xoptM LangExt.RequiredTypeArguments+      (imp_errs, hints) <- get_suggestions required_type_arguments what_looking whatName rdr+      hfdc <- getHoleFitDispConfig       unit_state <- hsc_units <$> getTopEnv       let-        -- TODO: unfortunate to have to convert to SDoc here.-        -- This should go away once we refactor ErrInfo.-        hint_msg = vcat $ map ppr hints-        import_err_msg = vcat $ map ppr import_errs-        info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }-      failWithTc $ TcRnMessageWithInfo unit_state (-              mkDetailedMessage info (TcRnIllegalTermLevelUse nm err))+        want_simple = want_simple_msg hints+        msg = TcRnIllegalTermLevelUse want_simple rdr nm err+        info = ErrInfo { errInfoContext =+                           if want_simple+                           then []+                           else maybeToList $ fmap (TermLevelUseCtxt nm) pprov+                       , errInfoSupplementary =+                           fmap ((hfdc,) . (:[]) . SupplementaryImportErrors) $+                             NE.nonEmpty imp_errs+                       , errInfoHints = hints+                       }+      failWithTc $ TcRnMessageWithInfo unit_state (mkDetailedMessage info msg) -    get_suggestions what_looking ns nm = do-      required_type_arguments <- xoptM LangExt.RequiredTypeArguments-      if required_type_arguments && isVarNameSpace ns+    get_suggestions required_type_arguments what_looking ns rdr = do+      show_helpful_errors <- goptM Opt_HelpfulErrors+      if not show_helpful_errors || (required_type_arguments && isVarNameSpace ns)       then return ([], [])  -- See Note [Suppress hints with RequiredTypeArguments]       else do-        let occ = mkOccNameFS ns (occNameFS (occName nm))+        let rdr' = fromMaybe rdr (demoteRdrName rdr)         lcl_env <- getLocalRdrEnv-        unknownNameSuggestions lcl_env what_looking (mkRdrUnqual occ)-{-+        unknownNameSuggestions lcl_env what_looking rdr'++-- | Should we display a simpler "out of scope" message to the user, instead of+-- a full-blown "illegal term-level use" message?+--+-- See Note [Simpler "illegal term-level use" errors]+want_simple_msg :: [GhcHint] -> Bool+want_simple_msg hints = any relevant_suggestion hints+  where+    relevant_suggestion = \case+      ImportSuggestion {} -> True+      SuggestSimilarNames {} -> True+      _ -> False++{- Note [Simpler "illegal term-level use" errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we rename the occurrence of A in the definition of 'f' in the following program:++  module M1 where+    data A = A Int+  module M2 where+    import M1 (A)+    f x = A x++we initially resolve 'A' to the type constructor 'A', in order to support+-XRequiredTypeArguments. Then we come to find out that a type is illegal in+this position. It is more user-friendly to report the problem as:++  Data constructor out of scope: A++rather than:++  Illegal term-level use of type constructor A++This was reported in #23982.++To achieve this, in 'failIllegalTyCon' and 'failIllegalTyVar', we include a+little heuristic to decide whether to emit an "out of scope" message rather than+an "illegal term-level use" message: when we have a term to suggest to the user,+then give the simpler "out of scope" error message.++For instance, in the example above, we suggest extending the import list to++  import M1 (A(A))++to bring the data constructor A into scope. We thus emit the following message:++    Data constructor out of scope: A+    Suggested fix:+      Add ‘A’ to the import list in the import of M1+ ************************************************************************ *                                                                      *                 Extending the global environment@@ -466,9 +520,8 @@ -- See GHC ticket #17820 . tcTyThBinders :: [TyThing] -> TcM ThBindEnv tcTyThBinders implicit_things = do-  stage <- getStage-  let th_lvl  = thLevel stage-      th_bndrs = mkNameEnv+  th_lvl <- thLevelIndex <$> getThLevel+  let th_bndrs = mkNameEnv                   [ ( n , (TopLevel, th_lvl) ) | n <- names ]   return th_bndrs   where@@ -640,7 +693,7 @@   tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed-                  -> [Scaled TcId] -> TcM a -> TcM (a, HsWrapper)+                  -> [Scaled TcId] -> TcM a -> TcM a -- Used for both top-level value bindings and nested let/where-bindings -- Adds to the TcBinderStack too tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)@@ -650,7 +703,7 @@           [ (idName id, ATcId { tct_id   = id                               , tct_info = mk_tct_info id })           | Scaled _ id <- ids ] $-    foldr check_usage ((, idHsWrapper) <$> thing_inside) scaled_names+    foldr check_usage thing_inside scaled_names   where     mk_tct_info id       | type_closed && isEmptyNameSet rhs_fvs = ClosedLet@@ -661,10 +714,9 @@         type_closed = isTypeClosedLetBndr id &&                       (fv_type_closed || hasCompleteSig sig_fn name)     scaled_names = [Scaled p (idName id) | Scaled p id <- ids ]-    check_usage :: Scaled Name -> TcM (a, HsWrapper) -> TcM (a, HsWrapper)+    check_usage :: Scaled Name -> TcM a -> TcM a     check_usage (Scaled p id) thing_inside = do-      ((res, inner_wrap), outer_wrap) <- tcCheckUsage id p thing_inside-      return $ (res, outer_wrap <.> inner_wrap)+      tcCheckUsage id p thing_inside  tcExtendIdEnv :: [TcId] -> TcM a -> TcM a -- For lambda-bound and case-bound Ids@@ -705,7 +757,7 @@   = do  { traceTc "tc_extend_local_env" (ppr extra_env)         ; updLclCtxt upd_lcl_env thing_inside }   where-    upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt  = stage+    upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt  = th_lvl                                , tcl_rdr      = rdr_env                                , tcl_th_bndrs = th_bndrs                                , tcl_env      = lcl_type_env })@@ -722,7 +774,7 @@               -- Template Haskell staging env simultaneously. Reason for extending               -- LocalRdrEnv: after running a TH splice we need to do renaming.       where-        thlvl = (top_lvl, thLevel stage)+        thlvl = (top_lvl, thLevelIndex th_lvl)   tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt@@ -869,34 +921,6 @@ ************************************************************************ -} -checkWellStaged :: StageCheckReason -- What the stage check is for-                -> ThLevel      -- Binding level (increases inside brackets)-                -> ThLevel      -- Use stage-                -> TcM ()       -- Fail if badly staged, adding an error-checkWellStaged pp_thing bind_lvl use_lvl-  | use_lvl >= bind_lvl         -- OK! Used later than bound-  = return ()                   -- E.g.  \x -> [| $(f x) |]--  | bind_lvl == outerLevel      -- GHC restriction on top level splices-  = failWithTc (TcRnStageRestriction pp_thing)--  | otherwise                   -- Badly staged-  = failWithTc $                -- E.g.  \x -> $(f x)-    TcRnBadlyStaged pp_thing bind_lvl use_lvl--topIdLvl :: Id -> ThLevel--- Globals may either be imported, or may be from an earlier "chunk"--- (separated by declaration splices) of this module.  The former---  *can* be used inside a top-level splice, but the latter cannot.--- Hence we give the former impLevel, but the latter topLevel--- E.g. this is bad:---      x = [| foo |]---      $( f x )--- By the time we are processing the $(f x), the binding for "x"--- will be in the global env, not the local one.-topIdLvl id | isLocalId id = outerLevel-            | otherwise    = impLevel- tcMetaTy :: Name -> TcM Type -- Given the name of a Template Haskell data type, -- return the type@@ -905,9 +929,9 @@     t <- tcLookupTyCon tc_name     return (mkTyConTy t) -isBrackStage :: ThStage -> Bool-isBrackStage (Brack {}) = True-isBrackStage _other     = False+isBrackLevel :: ThLevel -> Bool+isBrackLevel (Brack {}) = True+isBrackLevel _other     = False  {- ************************************************************************@@ -917,21 +941,28 @@ ************************************************************************ -} -{- Note [Default class defaults]+{- Note [Builtin class defaults] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In absence of user-defined `default` declarations, the set of class defaults in-effect (i.e. `DefaultEnv`) is determined by the absence or-presence of the `ExtendedDefaultRules` and `OverloadedStrings` extensions. In their-absence, the only rule in effect is `default Num (Integer, Double)` as specified by-Haskell Language Report.+In the absence of user-defined `default` declarations, the set of class defaults in+effect (i.e. the `DefaultEnv`) depends on whether the `ExtendedDefaultRules` and+`OverloadedStrings` extensions are enabled. In their absence, the only rule in effect+is `default Num (Integer, Double)`, as specified by the Haskell 2010 report. -In GHC's internal packages `DefaultEnv` is empty to minimize cross-module dependencies:-the `Num` class or `Integer` type may not even be available in low-level modules. If-you don't do this, attempted defaulting in package ghc-prim causes an actual crash-(attempting to look up the `Integer` type).+Remark [No built-in defaults in ghc-internal] -A user-defined `default` declaration overrides the defaults for the specified class,-and only for that class.+  When typechecking the ghc-internal package, we **do not** include any built-in+  defaults. This is because, in ghc-internal, types such as 'Num' or 'Integer' may+  not even be available (they haven't been typechecked yet).++Remark [default () in ghc-internal]++  Historically, modules inside ghc-internal have used a single default declaration,+  of the form `default ()`, to work around the problem described in+  Remark [No built-in defaults in ghc-internal].++  When we typecheck such a default declaration, we must also make sure not to fail+  if e.g. 'Num' is not in scope. We thus have special treatment for this case,+  in 'GHC.Tc.Gen.Default.tcDefaultDecls'. -}  tcGetDefaultTys :: TcM (DefaultEnv,  -- Default classes and types@@ -943,16 +974,16 @@                                         -- See also #1974               builtinDefaults cls tys = ClassDefaults{ cd_class = cls                                                      , cd_types = tys-                                                     , cd_module = Nothing+                                                     , cd_provenance = DP_Builtin                                                      , cd_warn = Nothing }          -- see Note [Named default declarations] in GHC.Tc.Gen.Default         ; defaults <- getDeclaredDefaultTys -- User-supplied defaults         ; this_module <- tcg_mod <$> getGblEnv         ; let this_unit = moduleUnit this_module-              is_internal_unit = this_unit `elem` [bignumUnit, ghcInternalUnit, primUnit]-        ; if is_internal_unit-             -- see Note [Default class defaults]+        ; if this_unit == ghcInternalUnit+          -- see Remark [No built-in defaults in ghc-internal]+          -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env           then return (defaults, extended_defaults)           else do               -- not one of the built-in units@@ -984,6 +1015,8 @@                                  }                    -- The Num class is already user-defaulted, no need to construct the builtin default                    _ -> pure emptyDefaultEnv+                -- Supply the built-in defaults, but make the user-supplied defaults+                -- override them.               ; let deflt_tys = mconcat [ extDef, numDef, ovlStr, defaults ]               ; return (deflt_tys, extended_defaults) } } @@ -1180,14 +1213,8 @@ notFound :: Name -> TcM TyThing notFound name   = do { lcl_env <- getLclEnv-       ; let stage = getLclEnvThStage lcl_env-       ; case stage of   -- See Note [Out of scope might be a staging error]-           Splice {}-             | isUnboundName name -> failM  -- If the name really isn't in scope-                                            -- don't report it again (#11941)-             | otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name))--           _ | isTermVarOrFieldNameSpace (nameNameSpace name) ->+       ; if isTermVarOrFieldNameSpace (nameNameSpace name)+           then                -- This code path is only reachable with RequiredTypeArguments enabled                -- via the following chain of calls:                --   `notFound`       called from@@ -1200,13 +1227,13 @@                -- See Note [Demotion of unqualified variables] (W1) in GHC.Rename.Env                failWithTc $ TcRnUnpromotableThing name TermVariablePE -             | otherwise -> failWithTc $-                mkTcRnNotInScope (getRdrName name) (NotInScopeTc (getLclEnvTypeEnv lcl_env))-                       -- Take care: printing the whole gbl env can-                       -- cause an infinite loop, in the case where we-                       -- are in the middle of a recursive TyCon/Class group;-                       -- so let's just not print it!  Getting a loop here is-                       -- very unhelpful, because it hides one compiler bug with another+           else failWithTc $+                 TcRnNotInScope (NotInScopeTc (getLclEnvTypeEnv lcl_env)) (getRdrName name)+                  -- Take care: printing the whole gbl env can+                  -- cause an infinite loop, in the case where we+                  -- are in the middle of a recursive TyCon/Class group;+                  -- so let's just not print it!  Getting a loop here is+                  -- very unhelpful, because it hides one compiler bug with another        }  wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -55,6 +55,7 @@ import GHC.Core ( isOrphan ) -- For the Coercion constructor import GHC.Core.Type import GHC.Core.TyCo.Ppr ( debugPprType )+import GHC.Core.TyCo.Tidy ( tidyType ) import GHC.Core.Class( Class ) import GHC.Core.Coercion.Axiom @@ -71,15 +72,17 @@ import GHC.Tc.Errors.Types import GHC.Tc.Zonk.Monad ( ZonkM ) +import GHC.Rename.Utils( mkRnSyntaxExpr )+ import GHC.Types.Id.Make( mkDictFunId ) import GHC.Types.Basic ( TypeOrKind(..), Arity, VisArity )-import GHC.Types.Error import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env+import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Types.Var import qualified GHC.LanguageExtensions as LangExt @@ -130,7 +133,7 @@        ; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $                  instCall origin ty_args theta -       ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) }+       ; return (mkHsWrap wrap (mkHsVar (noLocA id))) }  {- ************************************************************************@@ -487,7 +490,11 @@   = do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind        ; return (mkAppTys ty extra_args, kind') }   where-    n_invis = invisibleTyBndrCount kind+    n_invis = invisibleBndrCount kind+       -- We are re-using tcInstInvisibleTyBindersN, which is+       -- needed elsewhere; so all that matters is that n_invis+       -- is big enough! Does not matter if it is too big.+       -- 10,000 would do equally well :-)  tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind) -- Called only to instantiate kinds, in user-written type signatures@@ -574,9 +581,12 @@              ; (subst, inst_tvs) <- tcInstSuperSkolTyVars skol_info tvs                      -- We instantiate the dfun_tyd with superSkolems.                      -- See Note [Subtle interaction of recursion and overlap]-                     -- and Note [Binding when looking up instances]-             ; let inst_tys = substTys subst tys-                   skol_info_anon = mkClsInstSkol cls inst_tys }+                     -- and Note [Super skolems: binding when looking up instances]+             ; let inst_tys       = substTys subst tys+                   skol_info_anon = InstSkol IsClsInst (pSizeClassPred cls inst_tys)+                     -- We need to take the size of `inst_tys` (not `tys`) because+                     -- Paterson sizes mention the free type variables+             }         ; let inst_theta = substTheta subst theta        ; return (skol_info_anon, inst_tvs, inst_theta, cls, inst_tys) }@@ -585,7 +595,7 @@ -- Make skolem constants, but do *not* give them new names, as above -- As always, allocate them one level in -- Moreover, make them "super skolems"; see GHC.Core.InstEnv---    Note [Binding when looking up instances]+--    Note [Super skolems: binding when looking up instances] -- See Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered by scoping tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptySubst@@ -807,15 +817,14 @@     orig = LiteralOrigin lit  -------------mkOverLit :: OverLitVal -> TcM (HsLit (GhcPass p))+mkOverLit :: OverLitVal -> TcM (HsLit GhcTc) mkOverLit (HsIntegral i)   = do  { integer_ty <- tcMetaTy integerTyConName-        ; return (HsInteger (il_text i)-                            (il_value i) integer_ty) }+        ; return (XLit $ HsInteger  (il_text i) (il_value i) integer_ty) }  mkOverLit (HsFractional r)   = do  { rat_ty <- tcMetaTy rationalTyConName-        ; return (HsRat noExtField r rat_ty) }+        ; return (XLit $ HsRat r rat_ty) }  mkOverLit (HsIsString src s) = return (HsString src s) @@ -859,7 +868,7 @@ -- USED ONLY FOR CmdTop (sigh) *** -- See Note [CmdSyntaxTable] in "GHC.Hs.Expr" -tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))+tcSyntaxName orig ty (std_nm, HsVar _ (L _ (WithUserRdr _ user_nm)))   | std_nm == user_nm   = do rhs <- newMethodFromName orig std_nm [ty]        return (std_nm, rhs)@@ -882,15 +891,10 @@      hasFixedRuntimeRepRes std_nm user_nm_expr sigma1      return (std_nm, unLoc expr) -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan -> TidyEnv-               -> ZonkM (TidyEnv, SDoc)-syntaxNameCtxt name orig ty loc tidy_env = return (tidy_env, msg)-  where-    msg = vcat [ text "When checking that" <+> quotes (ppr name)-                          <+> text "(needed by a syntactic construct)"-               , nest 2 (text "has the required type:"-                         <+> ppr (tidyType tidy_env ty))-               , nest 2 (sep [ppr orig, text "at" <+> ppr loc])]+syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan+               -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)+syntaxNameCtxt name orig ty loc tidy_env =+  return (tidy_env, SyntaxNameCtxt name orig (tidyType tidy_env ty) loc)  {- ************************************************************************
compiler/GHC/Tc/Utils/Monad.hs view
@@ -15,12 +15,13 @@    -- * Simple accessors   discardResult,-  getTopEnv, updTopEnv, getGblEnv, updGblEnv,+  getTopEnv, updTopEnv, updTopEnvIO, getGblEnv, updGblEnv,   setGblEnv, getLclEnv, updLclEnv, updLclCtxt, setLclEnv, restoreLclEnv,   updTopFlags,   getEnvs, setEnvs, updEnvs, restoreEnvs,   xoptM, doptM, goptM, woptM,-  setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,+  setXOptM, setWOptM,+  unsetXOptM, unsetGOptM, unsetWOptM,   whenDOptM, whenGOptM, whenWOptM,   whenXOptM, unlessXOptM,   getGhcMode,@@ -75,7 +76,9 @@   -- * Shared error message stuff: renamer and typechecker   recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,   attemptM, tryTc,-  askNoErrs, discardErrs, tryTcDiscardingErrs,+  askNoErrs, discardErrs,+  tryTcDiscardingErrs,+  tryTcDiscardingErrs',   checkNoErrs, whenNoErrs,   ifErrsM, failIfErrsM, @@ -88,8 +91,9 @@   addErrTcM,   failWithTc, failWithTcM,   checkTc, checkTcM,+  checkJustTc, checkJustTcM,   failIfTc, failIfTcM,-  mkErrInfo,+  mkErrCtxt,   addTcRnDiagnostic, addDetailedDiagnostic,   mkTcRnMessage, reportDiagnostic, reportDiagnostics,   warnIf, diagnosticTc, diagnosticTcM,@@ -97,12 +101,12 @@    -- * Type constraints   newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,-  addTcEvBind, addTopEvBinds,-  getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,-  chooseUniqueOccTc,+  addTcEvBind, addTcEvBinds, addTopEvBinds,+  getTcEvBindsMap, setTcEvBindsMap, updTcEvBinds,+  getTcEvTyCoVars, chooseUniqueOccTc,   getConstraintVar, setConstraintVar,   emitConstraints, emitStaticConstraints, emitSimple, emitSimples,-  emitImplication, emitImplications,+  emitImplication, emitImplications, ensureReflMultiplicityCo,   emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError,   discardConstraints, captureConstraints, tryCaptureConstraints,   pushLevelAndCaptureConstraints,@@ -113,8 +117,8 @@   emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,    -- * Template Haskell context-  recordThUse, recordThSpliceUse, recordThNeededRuntimeDeps,-  keepAlive, getStage, getStageAndBindLevel, setStage,+  recordThUse, recordThNeededRuntimeDeps,+  keepAlive, getThLevel, getCurrentAndBindLevel, setThLevel,   addModFinalizersWithLclEnv,    -- * Safe Haskell context@@ -163,8 +167,10 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Evidence+import GHC.Tc.Types.LclEnv import GHC.Tc.Types.Origin import GHC.Tc.Types.TcRef+import GHC.Tc.Types.TH import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.TcType @@ -174,7 +180,7 @@ import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module.Warnings-import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable  import GHC.Core.UsageEnv import GHC.Core.Multiplicity@@ -183,9 +189,15 @@ import GHC.Core.Type( mkNumLitTy )  import GHC.Driver.Env+import GHC.Driver.Env.KnotVars import GHC.Driver.Session import GHC.Driver.Config.Diagnostic +import GHC.Iface.Errors.Types+import GHC.Iface.Errors.Ppr++import GHC.Linker.Types+ import GHC.Runtime.Context  import GHC.Data.IOEnv -- Re-export all@@ -199,6 +211,7 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger import qualified GHC.Data.Strict as Strict+import qualified Data.Set as Set  import GHC.Types.Error import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv )@@ -208,16 +221,16 @@ import GHC.Types.SafeHaskell import GHC.Types.Id import GHC.Types.TypeEnv-import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Ppr import GHC.Types.Unique.FM ( emptyUFM )+import GHC.Types.Unique.DFM import GHC.Types.Unique.Supply import GHC.Types.Annotations-import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )+import GHC.Types.Basic( TopLevelFlag(..), TypeOrKind(..) ) import GHC.Types.CostCentre.State import GHC.Types.SourceFile @@ -227,13 +240,9 @@ import Control.Monad  import qualified Data.Map as Map-import GHC.Driver.Env.KnotVars-import GHC.Linker.Types-import GHC.Types.Unique.DFM-import GHC.Iface.Errors.Types-import GHC.Iface.Errors.Ppr-import GHC.Tc.Types.LclEnv+import GHC.Core.Coercion (isReflCo) + {- ************************************************************************ *                                                                      *@@ -257,7 +266,6 @@  = do { keep_var     <- newIORef emptyNameSet ;         used_gre_var <- newIORef [] ;         th_var       <- newIORef False ;-        th_splice_var<- newIORef False ;         infer_var    <- newIORef True ;         infer_reasons_var <- newIORef emptyMessages ;         dfun_n_var   <- newIORef emptyOccSet ;@@ -319,8 +327,8 @@                 tcg_inst_env       = emptyInstEnv,                 tcg_fam_inst_env   = emptyFamInstEnv,                 tcg_ann_env        = emptyAnnEnv,+                tcg_complete_match_env = [],                 tcg_th_used        = th_var,-                tcg_th_splice_used = th_splice_var,                 tcg_th_needed_deps = th_needed_deps_var,                 tcg_exports        = [],                 tcg_imports        = emptyImportAvails,@@ -355,7 +363,6 @@                 tcg_zany_n         = zany_n_var,                 tcg_keep           = keep_var,                 tcg_hdr_info        = (Nothing,Nothing),-                tcg_hpc            = False,                 tcg_main           = Nothing,                 tcg_self_boot      = NoSelfBoot,                 tcg_safe_infer     = infer_var,@@ -394,7 +401,7 @@                 tcl_in_gen_code = False,                 tcl_ctxt       = [],                 tcl_rdr        = emptyLocalRdrEnv,-                tcl_th_ctxt    = topStage,+                tcl_th_ctxt    = topLevel,                 tcl_th_bndrs   = emptyNameEnv,                 tcl_arrow_ctxt = NoArrowCtxt,                 tcl_env        = emptyNameEnv,@@ -472,6 +479,11 @@ updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->                           env { env_top = upd top }) +updTopEnvIO :: (HscEnv -> IO HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updTopEnvIO upd = updEnvIO (\ env@(Env { env_top = top }) ->+                                upd top >>= \t' ->+                                pure env{ env_top = t' })+ getGblEnv :: TcRnIf gbl lcl gbl getGblEnv = do { Env{..} <- getEnv; return env_gbl } @@ -570,6 +582,9 @@ setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag) +setWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+setWOptM flag = updTopFlags (\dflags -> wopt_set dflags flag)+ unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag) @@ -1058,11 +1073,11 @@ -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt                       ; tidy_env <- liftZonkM $ tcInitTidyEnv-                      ; err_info <- mkErrInfo tidy_env ctxt-                      ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg+                      ; err_ctxt <- mkErrCtxt tidy_env ctxt+                      ; let detailed_msg = mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg                       ; add_long_err_at loc detailed_msg } -mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed+mkDetailedMessage :: ErrInfo-> TcRnMessage -> TcRnMessageDetailed mkDetailedMessage err_info msg =   TcRnMessageDetailed err_info msg @@ -1217,12 +1232,12 @@  -- | Add a fixed message to the error context. This message should not -- do any tidying.-addErrCtxt :: SDoc -> TcM a -> TcM a+addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-}   -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))  -- | Add a message to the error context. This message may do tidying.-addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a+addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-}  -- Note [Inlining addErrCtxt] addErrCtxtM ctxt = pushCtxt (False, ctxt) @@ -1230,13 +1245,13 @@ -- message is always sure to be reported, even if there is a lot of -- context. It also doesn't count toward the maximum number of contexts -- reported.-addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a+addLandmarkErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxt #-}  -- Note [Inlining addErrCtxt] addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))  -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations -- and tidying.-addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a+addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-}  -- Note [Inlining addErrCtxt] addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt) @@ -1370,11 +1385,13 @@                           tcTryM thing_inside         -- See Note [Constraints and errors]-       ; let lie_to_keep = case mb_res of-                             Nothing -> dropMisleading lie-                             Just {} -> lie--       ; return (mb_res, lie_to_keep) }+       ; case mb_res of+            Just {} -> return (mb_res, lie)+            Nothing -> do { let pruned_lie = dropMisleading lie+                          ; traceTc "tryCaptureConstraints" $+                            vcat [ text "lie:" <+> ppr lie+                                 , text "dropMisleading lie:" <+> ppr pruned_lie ]+                          ; return (Nothing, pruned_lie) } }  captureConstraints :: TcM a -> TcM (a, WantedConstraints) -- (captureConstraints m) runs m, and returns the type constraints it generates@@ -1510,21 +1527,37 @@ --      if 'main' succeeds with no error messages, it's the answer --      otherwise discard everything from 'main', including errors, --          and try 'recover' instead.-tryTcDiscardingErrs recover thing_inside+tryTcDiscardingErrs recover =+  tryTcDiscardingErrs'+    (\_ _ _ -> True)     -- No validation+    recover recover      -- Discard all errors and warnings+                         -- and unsolved constraints entirely++tryTcDiscardingErrs' :: (WantedConstraints -> Messages TcRnMessage -> r -> Bool)  -- Validation+                     -> TcM r  -- Recover from validation error+                     -> TcM r  -- Recover from failure+                     -> TcM r  -- Action to try+                     -> TcM r+-- (tryTcDiscardingErrs' validate recover_invalid recover_error thing_inside) tries 'thing_inside';+--      if 'thing_inside' succeeds and validation produces no errors, it's the answer+--      otherwise discard everything from 'thing_inside', including errors,+--          and try 'recover' instead.+tryTcDiscardingErrs' validate recover_invalid recover_error thing_inside   = do { ((mb_res, lie), msgs) <- capture_messages    $                                   capture_constraints $                                   tcTryM thing_inside         ; case mb_res of             Just res | not (errorsFound msgs)                      , not (insolubleWC lie)-              -> -- 'main' succeeded with no errors-                 do { addMessages msgs  -- msgs might still have warnings-                    ; emitConstraints lie-                    ; return res }+                    -- 'thing_inside' succeeded with no errors+              -> if validate lie msgs res+                 then do { addMessages msgs  -- msgs might still have warnings+                         ; emitConstraints lie+                         ; return res }+                 else recover_invalid -            _ -> -- 'main' failed, or produced an error message-                 recover     -- Discard all errors and warnings-                             -- and unsolved constraints entirely+            _ -> -- 'thing_inside' failed, or produced an error message+                 recover_error         }  {-@@ -1578,6 +1611,12 @@ checkTcM True  _   = return () checkTcM False err = failWithTcM err +checkJustTc :: TcRnMessage -> Maybe a -> TcM a+checkJustTc err = maybe (failWithTc err) pure++checkJustTcM :: (TidyEnv, TcRnMessage) -> Maybe a -> TcM a+checkJustTcM err = maybe (failWithTcM err) pure+ failIfTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is false failIfTc False _   = return () failIfTc True  err = failWithTc err@@ -1595,9 +1634,6 @@ warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'.   = when is_bad (addDiagnostic msg) -no_err_info :: ErrInfo-no_err_info = ErrInfo Outputable.empty Outputable.empty- -- | Display a warning if a condition is met. diagnosticTc :: Bool -> TcRnMessage -> TcM () diagnosticTc should_report warn_msg@@ -1620,22 +1656,23 @@ addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM () addDiagnosticTcM (env0, msg)  = do { ctxt <- getErrCtxt-      ; extra <- mkErrInfo env0 ctxt-      ; let err_info = ErrInfo extra Outputable.empty-            detailed_msg = mkDetailedMessage err_info msg+      ; extra <- mkErrCtxt env0 ctxt+      ; let detailed_msg = mkDetailedMessage (ErrInfo extra Nothing noHints) msg       ; add_diagnostic detailed_msg }  -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage' -- given some additional context about the diagnostic.-addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()+addDetailedDiagnostic :: ([ErrCtxtMsg] -> TcRnMessage) -> TcM () addDetailedDiagnostic mkMsg = do   loc <- getSrcSpanM   name_ppr_ctx <- getNamePprCtx   !diag_opts  <- initDiagOpts <$> getDynFlags   env0 <- liftZonkM tcInitTidyEnv   ctxt <- getErrCtxt-  err_info <- mkErrInfo env0 ctxt-  reportDiagnostic (mkMsgEnvelope diag_opts loc name_ppr_ctx (mkMsg (ErrInfo err_info empty)))+  err_info <- mkErrCtxt env0 ctxt+  reportDiagnostic $+    mkMsgEnvelope diag_opts loc name_ppr_ctx $+      mkMsg err_info  addTcRnDiagnostic :: TcRnMessage -> TcM () addTcRnDiagnostic msg = do@@ -1645,13 +1682,13 @@ -- | Display a diagnostic for the current source location, taken from -- the 'TcRn' monad. addDiagnostic :: TcRnMessage -> TcRn ()-addDiagnostic msg = add_diagnostic (mkDetailedMessage no_err_info msg)+addDiagnostic msg = add_diagnostic (mkDetailedMessage (ErrInfo [] Nothing noHints) msg)  -- | Display a diagnostic for a given source location. addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn () addDiagnosticAt loc msg = do   unit_state <- hsc_units <$> getTopEnv-  let detailed_msg = mkDetailedMessage no_err_info msg+  let detailed_msg = mkDetailedMessage (ErrInfo [] Nothing noHints) msg   mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic  -- | Display a diagnostic, with an optional flag, for the current source@@ -1663,7 +1700,6 @@        ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic        } - {- -----------------------------------         Other helper functions@@ -1673,12 +1709,13 @@             -> [ErrCtxt]             -> TcM () add_err_tcm tidy_env msg loc ctxt- = do { err_info <- mkErrInfo tidy_env ctxt ;-        add_long_err_at loc (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) }+ = do { err_ctxt <- mkErrCtxt tidy_env ctxt+      ; add_long_err_at loc $+          mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg } -mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc+mkErrCtxt :: TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] -- Tidy the error info, trimming excessive contexts-mkErrInfo env ctxts+mkErrCtxt env ctxts --  = do --       dbg <- hasPprDebug <$> getDynFlags --       if dbg                -- In -dppr-debug style the output@@ -1686,14 +1723,14 @@ --          else go dbg 0 env ctxts  = go False 0 env ctxts  where-   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc-   go _ _ _   [] = return empty+   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg]+   go _ _ _   [] = return []    go dbg n env ((is_landmark, ctxt) : ctxts)      | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg      = do { (env', msg) <- liftZonkM $ ctxt env           ; let n' = if is_landmark then n else n+1           ; rest <- go dbg n' env' ctxts-          ; return (msg $$ rest) }+          ; return (msg : rest) }      | otherwise      = go dbg n env ctxts @@ -1724,7 +1761,7 @@  newTcEvBinds :: TcM EvBindsVar newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap-                  ; tcvs_ref  <- newTcRef emptyVarSet+                  ; tcvs_ref  <- newTcRef []                   ; uniq <- newUnique                   ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)                   ; return (EvBindsVar { ebv_binds = binds_ref@@ -1736,7 +1773,7 @@ -- must be made monadically newNoTcEvBinds :: TcM EvBindsVar newNoTcEvBinds-  = do { tcvs_ref  <- newTcRef emptyVarSet+  = do { tcvs_ref  <- newTcRef []        ; uniq <- newUnique        ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)        ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref@@ -1747,14 +1784,14 @@ -- solving don't pollute the original cloneEvBindsVar ebv@(EvBindsVar {})   = do { binds_ref <- newTcRef emptyEvBindMap-       ; tcvs_ref  <- newTcRef emptyVarSet+       ; tcvs_ref  <- newTcRef []        ; return (ebv { ebv_binds = binds_ref                      , ebv_tcvs = tcvs_ref }) } cloneEvBindsVar ebv@(CoEvBindsVar {})-  = do { tcvs_ref  <- newTcRef emptyVarSet+  = do { tcvs_ref  <- newTcRef []        ; return (ebv { ebv_tcvs = tcvs_ref }) } -getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet+getTcEvTyCoVars :: EvBindsVar -> TcM [TcCoercion] getTcEvTyCoVars ev_binds_var   = readTcRef (ebv_tcvs ev_binds_var) @@ -1773,16 +1810,52 @@   | otherwise   = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) +updTcEvBinds :: EvBindsVar -> EvBindsVar -> TcM ()+updTcEvBinds (EvBindsVar { ebv_binds = old_ebv_ref, ebv_tcvs = old_tcv_ref })+             (EvBindsVar { ebv_binds = new_ebv_ref, ebv_tcvs = new_tcv_ref })+  = do { new_ebvs <- readTcRef new_ebv_ref+       ; updTcRef old_ebv_ref (`unionEvBindMap` new_ebvs)+       ; new_tcvs <- readTcRef new_tcv_ref+       ; updTcRef old_tcv_ref (new_tcvs ++) }+updTcEvBinds (EvBindsVar { ebv_tcvs = old_tcv_ref })+             (CoEvBindsVar { ebv_tcvs = new_tcv_ref })+  = do { new_tcvs <- readTcRef new_tcv_ref+       ; updTcRef old_tcv_ref (new_tcvs ++) }+updTcEvBinds (CoEvBindsVar { ebv_tcvs = old_tcv_ref })+             (CoEvBindsVar { ebv_tcvs = new_tcv_ref })+  = do { new_tcvs <- readTcRef new_tcv_ref+       ; updTcRef old_tcv_ref (new_tcvs ++) }+updTcEvBinds old_var new_var+  = pprPanic "updTcEvBinds" (ppr old_var $$ ppr new_var)+    -- Terms inside types, no good+ addTcEvBind :: EvBindsVar -> EvBind -> TcM () -- Add a binding to the TcEvBinds by side effect addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind-  = do { traceTc "addTcEvBind" $ ppr u $$-                                 ppr ev_bind-       ; bnds <- readTcRef ev_ref-       ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }+  = do { bnds <- readTcRef ev_ref+       ; let bnds' = extendEvBinds bnds ev_bind+       ; traceTc "addTcEvBind" $+         vcat [ text "EvBindsVar:" <+> ppr u+              , text "ev_bind:" <+> ppr ev_bind+              , text "bnds:" <+> ppr bnds+              , text "bnds':" <+> ppr bnds' ]+       ; writeTcRef ev_ref bnds' } addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind   = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) +addTcEvBinds :: EvBindsVar -> EvBindMap -> TcM ()+-- ^ Add a collection of binding to the TcEvBinds by side effect+addTcEvBinds _ new_ev_binds+  | isEmptyEvBindMap new_ev_binds+  = return ()+addTcEvBinds (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) new_ev_binds+  = do { traceTc "addTcEvBinds" $ ppr u $$+                                  ppr new_ev_binds+       ; old_bnds <- readTcRef ev_ref+       ; writeTcRef ev_ref (old_bnds `unionEvBindMap` new_ev_binds) }+addTcEvBinds (CoEvBindsVar { ebv_uniq = u }) new_ev_binds+  = pprPanic "addTcEvBinds CoEvBindsVar" (ppr new_ev_binds $$ ppr u)+ chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName chooseUniqueOccTc fn =   do { env <- getGblEnv@@ -1868,6 +1941,15 @@        ; lie_var <- getConstraintVar        ; updTcRef lie_var (`addNotConcreteError` err) } +-- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify.+ensureReflMultiplicityCo :: TcCoercion -> CtOrigin -> TcM ()+ensureReflMultiplicityCo mult_co origin+  = do { traceTc "ensureReflMultiplicityCo" (ppr mult_co)+       ; unless (isReflCo mult_co) $ do+           { loc <- getCtLocM origin Nothing+           ; lie_var <- getConstraintVar+           ; updTcRef lie_var (\w -> addMultiplicityCoercionError w mult_co loc) } }+ -- | Throw out any constraints emitted by the thing_inside discardConstraints :: TcM a -> TcM a discardConstraints thing_inside = fst <$> captureConstraints thing_inside@@ -2009,30 +2091,53 @@   emitted some constraints with skolem-escape problems.  * If we discard too /few/ constraints, we may get the misleading-  class constraints mentioned above.  But we may /also/ end up taking-  constraints built at some inner level, and emitting them at some-  outer level, and then breaking the TcLevel invariants-  See Note [TcLevel invariants] in GHC.Tc.Utils.TcType+  class constraints mentioned above. -So dropMisleading has a horridly ad-hoc structure.  It keeps only-/insoluble/ flat constraints (which are unlikely to very visibly trip-up on the TcLevel invariant, but all /implication/ constraints (except-the class constraints inside them).  The implication constraints are-OK because they set the ambient level before attempting to solve any-inner constraints.  Ugh! I hate this. But it seems to work.+  We may /also/ end up taking constraints built at some inner level, and+  emitting them (via the exception catching in `tryCaptureConstraints` at some+  outer level, and then breaking the TcLevel invariants See Note [TcLevel+  invariants] in GHC.Tc.Utils.TcType -However note that freshly-generated constraints like (Int ~ Bool), or-((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as-insoluble.  The constraint solver does that.  So they'll be discarded.-That's probably ok; but see th/5358 as a not-so-good example:-   t1 :: Int-   t1 x = x   -- Manifestly wrong+So `dropMisleading` has a horridly ad-hoc structure: -   foo = $(...raises exception...)-We report the exception, but not the bug in t1.  Oh well.  Possible-solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints.+* It keeps only /insoluble/ flat constraints (which are unlikely to very visibly+  trip up on the TcLevel invariant +* But it keeps all /implication/ constraints (except the class constraints+  inside them).  The implication constraints are OK because they set the ambient+  level before attempting to solve any inner constraints. +Ugh! I hate this. But it seems to work.++Other wrinkles++(CERR1) Note that freshly-generated constraints like (Int ~ Bool), or+    ((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as+    insoluble.  The constraint solver does that.  So they'll be discarded.+    That's probably ok; but see th/5358 as a not-so-good example:+       t1 :: Int+       t1 x = x   -- Manifestly wrong++       foo = $(...raises exception...)+    We report the exception, but not the bug in t1.  Oh well.  Possible+    solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints.++(CERR2) In #26015 I found that from the constraints+           [W] alpha ~ Int      -- A class constraint+           [W] F alpha ~# Bool  -- An equality constraint+  we were dropping the first (becuase it's a class constraint) but not the+  second, and then getting a misleading error message from the second.  As+  #25607 shows, we can get not just one but a zillion bogus messages, which+  conceal the one genuine error.  Boo.++  For now I have added an even more ad-hoc "drop class constraints except+  equality classes (~) and (~~)"; see `dropMisleading`.  That just kicks the can+  down the road; but this problem seems somewhat rare anyway.  The code in+  `dropMisleading` hasn't changed for years.++It would be great to have a more systematic solution to this entire mess.++ ************************************************************************ *                                                                      *              Template Haskell context@@ -2043,9 +2148,6 @@ recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } -recordThSpliceUse :: TcM ()-recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }- recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM () recordThNeededRuntimeDeps new_links new_pkgs   = do { env <- getGblEnv@@ -2061,19 +2163,39 @@        ; traceRn "keep alive" (ppr name)        ; updTcRef (tcg_keep env) (`extendNameSet` name) } -getStage :: TcM ThStage-getStage = do { env <- getLclEnv; return (getLclEnvThStage env) }+getThLevel :: TcM ThLevel+getThLevel = do { env <- getLclEnv; return (getLclEnvThLevel env) } -getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))-getStageAndBindLevel name+getCurrentAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel))+getCurrentAndBindLevel name   = do { env <- getLclEnv;        ; case lookupNameEnv (getLclEnvThBndrs env) name of-           Nothing                  -> return Nothing-           Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, getLclEnvThStage env)) }+           Nothing                  -> do+              lvls <- getExternalBindLvl name+              if Set.empty == lvls+                -- This case happens when code is generated for identifiers which are not+                -- in scope.+                --+                -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||]+                then do+                  return Nothing+                else return (Just (TopLevel, lvls, getLclEnvThLevel env))+           Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env)) } -setStage :: ThStage -> TcM a -> TcRn a-setStage s = updLclEnv (setLclEnvThStage s)+getExternalBindLvl :: Name -> TcRn (Set.Set ThLevelIndex)+getExternalBindLvl name = do+  env <- getGlobalRdrEnv+  mod <- getModule+  case lookupGRE_Name env name of+    Just gre -> return $ (Set.map thLevelIndexFromImportLevel (greLevels gre))+    Nothing ->+      if nameIsLocalOrFrom mod name+        then return $ Set.singleton topLevelIndex+        else return Set.empty +setThLevel :: ThLevel -> TcM a -> TcRn a+setThLevel l = updLclEnv (setLclEnvThLevel l)+ -- | Adds the given modFinalizers to the global environment and set them to use -- the current local environment. addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()@@ -2326,13 +2448,14 @@ getCompleteMatchesTcM :: TcM CompleteMatches getCompleteMatchesTcM   = do { hsc_env <- getTopEnv-       ; tcg_env <- getGblEnv        ; eps <- liftIO $ hscEPS hsc_env-       ; return $ localAndImportedCompleteMatches (tcg_complete_matches tcg_env) hsc_env eps+       ; tcg_env <- getGblEnv+       ; let tcg_comps = tcg_complete_match_env tcg_env+       ; liftIO $ localAndImportedCompleteMatches tcg_comps eps        } -localAndImportedCompleteMatches :: CompleteMatches -> HscEnv -> ExternalPackageState -> CompleteMatches-localAndImportedCompleteMatches tcg_comps hsc_env eps =-     tcg_comps                -- from the current module-  ++ hptCompleteSigs hsc_env  -- from the home package-  ++ eps_complete_matches eps -- from imports+localAndImportedCompleteMatches :: CompleteMatches -> ExternalPackageState -> IO CompleteMatches+localAndImportedCompleteMatches tcg_comps eps = do+  return $+       tcg_comps                -- from the current modulea and from the home package+    ++ eps_complete_matches eps -- from external packages
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE LambdaCase      #-}-{-# LANGUAGE MultiWayIf      #-}-{-# LANGUAGE RecursiveDo     #-}-{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiWayIf            #-}+{-# LANGUAGE RecursiveDo           #-}+{-# LANGUAGE TupleSections         #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-@@ -41,14 +42,13 @@   -- Creating new evidence variables   newEvVar, newEvVars, newDict,   newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv,-  emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,+  emitWanted, emitWantedEq, emitWantedEvVar,   emitWantedEqs,   newTcEvBinds, newNoTcEvBinds, addTcEvBind,   emitNewExprHole, -  newCoercionHole, newCoercionHoleO, newVanillaCoercionHole,+  newCoercionHole,   fillCoercionHole, isFilledCoercionHole,-  unpackCoercionHole, unpackCoercionHole_maybe,   checkCoercionHole,    newImplication,@@ -65,7 +65,7 @@   -- Expected types   ExpType(..), ExpSigmaType, ExpRhoType,   mkCheckExpType, newInferExpType, newInferExpTypeFRR,-  tcInfer, tcInferFRR,+  runInfer, runInferRho, runInferSigma, runInferKind, runInferRhoFRR, runInferSigmaFRR,   readExpType, readExpType_maybe, readScaledExpType,   expTypeToType, scaledExpTypeToType,   checkingExpType_maybe, checkingExpType,@@ -78,13 +78,12 @@   ---------------------------------   -- Promotion, defaulting, skolemisation   defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet,-  quantifyTyVars, isQuantifiableTv,+  quantifyTyVars, doNotQuantifyTyVars,   zonkAndSkolemise, skolemiseQuantifiedTyVar,-  doNotQuantifyTyVars,    candidateQTyVarsOfType,  candidateQTyVarsOfKind,   candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,-  candidateQTyVarsWithBinders,+  candidateQTyVarsWithBinders, weedOutCandidates,   CandidatesQTvs(..), delCandidates,   candidateKindVars, partitionCandidates, @@ -111,11 +110,10 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence-import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin )+import GHC.Tc.Types.CtLoc( CtLoc ) import GHC.Tc.Utils.Monad        -- TcType, amongst others import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types-import GHC.Tc.Zonk.Type import GHC.Tc.Zonk.TcType  import GHC.Builtin.Names@@ -124,6 +122,7 @@ import GHC.Core.DataCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Tidy import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.Coercion@@ -201,12 +200,13 @@ newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence newWantedWithLoc loc pty   = do dst <- case classifyPredType pty of-                EqPred {} -> HoleDest  <$> newCoercionHole loc pty+                EqPred {} -> HoleDest  <$> newCoercionHole pty                 _         -> EvVarDest <$> newEvVar pty-       return $ CtWanted { ctev_dest      = dst-                         , ctev_pred      = pty-                         , ctev_loc       = loc-                         , ctev_rewriters = emptyRewriterSet }+       return $ CtWanted $+         WantedCt { ctev_dest      = dst+                  , ctev_pred      = pty+                  , ctev_loc       = loc+                  , ctev_rewriters = emptyRewriterSet }  -- | Create a new Wanted constraint with the given 'CtOrigin', and -- location information taken from the 'TcM' environment.@@ -226,10 +226,10 @@ ----------------------------------------------  cloneWantedCtEv :: CtEvidence -> TcM CtEvidence-cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _, ctev_loc = loc })-  | isEqPrimPred pty-  = do { co_hole <- newCoercionHole loc pty-       ; return (ctev { ctev_dest = HoleDest co_hole }) }+cloneWantedCtEv (CtWanted ctev@(WantedCt { ctev_pred = pty, ctev_dest = HoleDest _ }))+  | isEqPred pty+  = do { co_hole <- newCoercionHole pty+       ; return $ CtWanted (ctev { ctev_dest = HoleDest co_hole }) }   | otherwise   = pprPanic "cloneWantedCtEv" (ppr pty) cloneWantedCtEv ctev = return ctev@@ -276,16 +276,16 @@ -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion emitWantedEq origin t_or_k role ty1 ty2-  = do { hole <- newCoercionHoleO origin pty+  = do { hole <- newCoercionHole pty        ; loc  <- getCtLocM origin (Just t_or_k)-       ; emitSimple $ mkNonCanonical $-         CtWanted { ctev_pred      = pty-                  , ctev_dest      = HoleDest hole-                  , ctev_loc       = loc-                  , ctev_rewriters = emptyRewriterSet }+       ; emitSimple $ mkNonCanonical $ CtWanted $+           WantedCt { ctev_pred      = pty+                    , ctev_dest      = HoleDest hole+                    , ctev_loc       = loc+                    , ctev_rewriters = emptyRewriterSet }        ; return (HoleCo hole) }   where-    pty = mkPrimEqPredRole role ty1 ty2+    pty = mkEqPredRole role ty1 ty2  -- | Creates a new EvVar and immediately emits it as a Wanted. -- No equality predicates here.@@ -293,16 +293,13 @@ emitWantedEvVar origin ty   = do { new_cv <- newEvVar ty        ; loc <- getCtLocM origin Nothing-       ; let ctev = CtWanted { ctev_pred      = ty+       ; let ctev = WantedCt { ctev_pred      = ty                              , ctev_dest      = EvVarDest new_cv                              , ctev_loc       = loc                              , ctev_rewriters = emptyRewriterSet }-       ; emitSimple $ mkNonCanonical ctev+       ; emitSimple $ mkNonCanonical $ CtWanted ctev        ; return new_cv } -emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]-emitWantedEvVars orig = mapM (emitWantedEvVar orig)- -- | Emit a new wanted expression hole emitNewExprHole :: RdrName         -- of the hole                 -> Type -> TcM HoleExprRef@@ -358,23 +355,13 @@ ************************************************************************ -} -newVanillaCoercionHole :: TcPredType -> TcM CoercionHole-newVanillaCoercionHole = new_coercion_hole False--newCoercionHole :: CtLoc -> TcPredType -> TcM CoercionHole-newCoercionHole loc = newCoercionHoleO (ctLocOrigin loc)--newCoercionHoleO :: CtOrigin -> TcPredType -> TcM CoercionHole-newCoercionHoleO (KindEqOrigin {}) pty = new_coercion_hole True pty-newCoercionHoleO _ pty                 = new_coercion_hole False pty--new_coercion_hole :: Bool -> TcPredType -> TcM CoercionHole-new_coercion_hole hetero_kind pred_ty+newCoercionHole :: TcPredType -> TcM CoercionHole+-- For the Bool, see (EIK2) in Note [Equalities with heterogeneous kinds]+newCoercionHole pred_ty   = do { co_var <- newEvVar pred_ty        ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty)        ; ref <- newMutVar Nothing-       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref-                               , ch_hetero_kind = hetero_kind } }+       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }  -- | Put a value in a coercion hole fillCoercionHole :: CoercionHole -> Coercion -> TcM ()@@ -451,30 +438,29 @@  -- actual data definition is in GHC.Tc.Utils.TcType -newInferExpType :: TcM ExpType-newInferExpType = new_inferExpType Nothing+newInferExpType :: InferInstFlag -> TcM ExpType+newInferExpType iif = new_inferExpType iif IFRR_Any -newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR-newInferExpTypeFRR frr_orig-  = do { th_stage <- getStage-       ; if-          -- See [Wrinkle: Typed Template Haskell]-          -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.-          | Brack _ (TcPending {}) <- th_stage-          -> new_inferExpType Nothing+newInferExpTypeFRR :: InferInstFlag -> FixedRuntimeRepContext -> TcM ExpTypeFRR+newInferExpTypeFRR iif frr_orig+  = do { th_lvl <- getThLevel+       ; let mb_frr = case th_lvl of+                        TypedBrack {} -> IFRR_Any+                        _             -> IFRR_Check frr_orig+               -- mb_frr: see [Wrinkle: Typed Template Haskell]+               -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. -          | otherwise-          -> new_inferExpType (Just frr_orig) }+       ; new_inferExpType iif mb_frr } -new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType-new_inferExpType mb_frr_orig+new_inferExpType :: InferInstFlag -> InferFRRFlag -> TcM ExpType+new_inferExpType iif ifrr   = do { u <- newUnique        ; tclvl <- getTcLevel        ; traceTc "newInferExpType" (ppr u <+> ppr tclvl)        ; ref <- newMutVar Nothing        ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl-                           , ir_ref = ref-                           , ir_frr = mb_frr_orig })) }+                           , ir_inst = iif, ir_frr  = ifrr+                           , ir_ref  = ref })) }  -- | Extract a type out of an ExpType, if one exists. But one should always -- exist. Unless you're quite sure you know what you're doing.@@ -528,12 +514,12 @@   where     -- See Note [TcLevel of ExpType]     new_meta = case mb_frr of-      Nothing  ->  do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy+      IFRR_Any ->  do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy                       ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) }-      Just frr -> mdo { rr  <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy-                      ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)-                      ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr-                      ; return tau }+      IFRR_Check frr -> mdo { rr  <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy+                            ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)+                            ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr+                            ; return tau }  {- Note [inferResultToType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -550,20 +536,31 @@ -- | Infer a type using a fresh ExpType -- See also Note [ExpType] in "GHC.Tc.Utils.TcMType" ----- Use 'tcInferFRR' if you require the type to have a fixed+-- Use 'runInferFRR' if you require the type to have a fixed -- runtime representation.-tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)-tcInfer = tc_infer Nothing+runInferSigma :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+runInferSigma = runInfer IIF_Sigma IFRR_Any --- | Like 'tcInfer', except it ensures that the resulting type+runInferRho :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType)+runInferRho = runInfer IIF_DeepRho IFRR_Any++runInferKind :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+-- Used for kind-checking types, where we never want deep instantiation,+-- nor FRR checks+runInferKind = runInfer IIF_Sigma IFRR_Any++-- | Like 'runInferRho', except it ensures that the resulting type -- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in -- GHC.Tc.Utils.Concrete.-tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR)-tcInferFRR frr_orig = tc_infer (Just frr_orig)+runInferRhoFRR :: FixedRuntimeRepContext -> (ExpRhoTypeFRR -> TcM a) -> TcM (a, TcRhoTypeFRR)+runInferRhoFRR frr_orig = runInfer IIF_DeepRho (IFRR_Check frr_orig) -tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)-tc_infer mb_frr tc_check-  = do { res_ty <- new_inferExpType mb_frr+runInferSigmaFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR)+runInferSigmaFRR frr_orig = runInfer IIF_Sigma (IFRR_Check frr_orig)++runInfer :: InferInstFlag -> InferFRRFlag -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+runInfer iif mb_frr tc_check+  = do { res_ty <- new_inferExpType iif mb_frr        ; result <- tc_check res_ty        ; res_ty <- readExpType res_ty        ; return (result, res_ty) }@@ -756,7 +753,7 @@   = do  { name    <- newMetaTyVarName tyvar_name         ; details <- newMetaDetails meta_info         ; let tyvar = mkTcTyVar name kind details-        ; traceTc "newAnonMetaTyVar" (ppr tyvar)+        ; traceTc "newAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr kind)         ; return tyvar }  -- makes a new skolem tv@@ -798,11 +795,11 @@                  -> FastString -> TcKind -> TcM TcTyVar newConcreteTyVar reason fs kind   = assertPpr (isConcreteType kind) assert_msg $-  do { th_stage <- getStage+  do { th_lvl <- getThLevel      ; if         -- See [Wrinkle: Typed Template Haskell]         -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.-        | Brack _ (TcPending {}) <- th_stage+        | TypedBrack _ <- th_lvl         -> newNamedAnonMetaTyVar fs TauTv kind          | otherwise@@ -831,8 +828,8 @@         ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar))         ; return tyvar } --- Make a new CycleBreakerTv. See Note [Type equality cycles]--- in GHC.Tc.Solver.Equality+-- | Make a new cycle-breaker type variable. See Note [Type equality cycles]+-- in GHC.Tc.Solver.Equality. newCycleBreakerTyVar :: TcKind -> TcM TcTyVar newCycleBreakerTyVar kind   = do { details <- newMetaDetails CycleBreakerTv@@ -984,9 +981,9 @@ -- in GHC.Tc.Utils.Concrete. newOpenFlexiFRRTyVar :: FixedRuntimeRepContext -> TcM TcTyVar newOpenFlexiFRRTyVar frr_ctxt-  = do { th_stage <- getStage-       ; case th_stage of-          { Brack _ (TcPending {}) -- See [Wrinkle: Typed Template Haskell]+  = do { th_lvl <- getThLevel+       ; case th_lvl of+          { TypedBrack _ -- See [Wrinkle: Typed Template Haskell]               -> newOpenFlexiTyVar -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.           ; _ ->    mdo { let conc_orig = ConcreteFRR $@@ -1038,11 +1035,11 @@ -- | Like 'newMetaTyVarX', but for concrete type variables. newConcreteTyVarX :: ConcreteTvOrigin -> Subst -> TyVar -> TcM (Subst, TcTyVar) newConcreteTyVarX conc subst tv-  = do { th_stage <- getStage+  = do { th_lvl <- getThLevel        ; if           -- See [Wrinkle: Typed Template Haskell]           -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.-          | Brack _ (TcPending {}) <- th_stage+          | TypedBrack _  <- th_lvl           -> new_meta_tv_x TauTv subst tv           | otherwise           -> new_meta_tv_x (ConcreteTv conc) subst tv }@@ -1343,6 +1340,10 @@                                              , text "dv_tvs =" <+> ppr tvs                                              , text "dv_cvs =" <+> ppr cvs ]) +weedOutCandidates :: (DTyVarSet -> DTyVarSet) -> CandidatesQTvs -> CandidatesQTvs+weedOutCandidates weed_out dv@(DV { dv_kvs = kvs, dv_tvs = tvs })+  = dv { dv_kvs = weed_out kvs, dv_tvs = weed_out tvs }+ isEmptyCandidates :: CandidatesQTvs -> Bool isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs })   = isEmptyDVarSet kvs && isEmptyDVarSet tvs@@ -1577,7 +1578,7 @@     go_co dv (SubCo co)              = go_co dv co      go_co dv (HoleCo hole)-      = do m_co <- unpackCoercionHole_maybe hole+      = do m_co <- liftZonkM (unpackCoercionHole_maybe hole)            case m_co of              Just co -> go_co dv co              Nothing -> go_cv dv (coHoleCoVar hole)@@ -1788,15 +1789,6 @@       | otherwise       = Just <$> skolemiseQuantifiedTyVar skol_info tkv -isQuantifiableTv :: TcLevel   -- Level of the context, outside the quantification-                 -> TcTyVar-                 -> Bool-isQuantifiableTv outer_tclvl tcv-  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately-  = tcTyVarLevel tcv `strictlyDeeperThan` outer_tclvl-  | otherwise-  = False- zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> ZonkM TcTyCoVar -- A tyvar binder is never a unification variable (TauTv), -- rather it is always a skolem. It *might* be a TyVarTv.@@ -2269,27 +2261,24 @@  -- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the -- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the--- usage environment. See also Note [Coercions returned from tcSubMult] in--- GHC.Tc.Utils.Unify, which applies to the wrapper returned from this function.-tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper)+-- usage environment.+tcCheckUsage :: Name -> Mult -> TcM a -> TcM a tcCheckUsage name id_mult thing_inside   = do { (local_usage, result) <- tcCollectingUsage thing_inside-       ; wrapper <- check_then_add_usage local_usage-       ; return (result, wrapper) }+       ; check_usage (lookupUE local_usage name)+       ; tcEmitBindingUsage (deleteUE local_usage name)+       ; return result }     where-    check_then_add_usage :: UsageEnv -> TcM HsWrapper+    check_usage :: Usage -> TcM ()     -- Checks that the usage of the newly introduced binder is compatible with-    -- its multiplicity, and combines the usage of non-new binders to |uenv|-    check_then_add_usage uenv-      = do { let actual_u = lookupUE uenv name-           ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u)-           ; wrapper <- case actual_u of-               Bottom -> return idHsWrapper+    -- its multiplicity.+    check_usage actual_u+      = do { traceTc "check_usage" (ppr id_mult $$ ppr actual_u)+           ; case actual_u of+               Bottom -> return ()                Zero     -> tcSubMult (UsageEnvironmentOf name) ManyTy id_mult                MUsage m -> do { m <- promote_mult m-                              ; tcSubMult (UsageEnvironmentOf name) m id_mult }-           ; tcEmitBindingUsage (deleteUE uenv name)-           ; return wrapper }+                              ; tcSubMult (UsageEnvironmentOf name) m id_mult } }      -- This is gross. The problem is in test case typecheck/should_compile/T18998:     --   f :: a %1-> Id n a -> Id n a@@ -2371,7 +2360,7 @@       | isWordTy res_ty && platformInWordRange platform i       = Just (mkLit wordDataCon (HsWordPrim src i))       | isIntegerTy res_ty-      = Just (HsLit noExtField (HsInteger src i res_ty))+      = Just (HsLit noExtField (XLit $ HsInteger src i res_ty))       | otherwise       = go_fractional (integralFractionalLit neg i)         -- The 'otherwise' case is important@@ -2417,7 +2406,7 @@ -- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType -- Return True <=> we did some promotion -- Also returns either the original tyvar (no promotion) or the new one--- See Note [Promoting unification variables]+-- See Note [Promote monomorphic tyvars] in GHC.Tc.Solver promoteMetaTyVarTo tclvl tv   | assertPpr (isMetaTyVar tv) (ppr tv) $     tcTyVarLevel tv `strictlyDeeperThan` tclvl@@ -2462,14 +2451,11 @@   unless (typeHasFixedRuntimeRep ty)     (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov) -{--%************************************************************************-%*                                                                      *+{- **********************************************************************+*                                                                       *              Error messages *                                                                       *-*************************************************************************---}+********************************************************************** -}  -- See Note [Naughty quantification candidates] naughtyQuantification :: TcType   -- original type user wanted to quantify
compiler/GHC/Tc/Utils/TcMType.hs-boot view
@@ -3,6 +3,5 @@ import GHC.Tc.Types import GHC.Types.Name import GHC.Core.TyCo.Rep-import GHC.Tc.Types.Evidence -tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper)+tcCheckUsage :: Name -> Mult -> TcM a -> TcM a
compiler/GHC/Tc/Utils/Unify.hs view
@@ -1,3615 +1,4764 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE RecursiveDo         #-}-{-# LANGUAGE MultiWayIf          #-}-{-# LANGUAGE RecordWildCards     #-}--{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}---- | Type subsumption and unification-module GHC.Tc.Utils.Unify (-  -- Full-blown subsumption-  tcWrapResult, tcWrapResultO, tcWrapResultMono,-  tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS,-  tcSubTypeAmbiguity, tcSubMult, tcSubMult',-  checkConstraints, checkTvConstraints,-  buildImplicationFor, buildTvImplication, emitResidualTvConstraint,--  -- Skolemisation-  DeepSubsumptionFlag(..), getDeepSubsumptionFlag, isRhoTyDS,-  tcSkolemise, tcSkolemiseCompleteSig, tcSkolemiseExpectedType,--  -- Various unifications-  unifyType, unifyKind, unifyInvisibleType, unifyExpectedType,-  unifyExprType, unifyTypeAndEmit, promoteTcType,-  swapOverTyVars, touchabilityAndShapeTest, checkTopShape, lhsPriority,-  UnifyEnv(..), updUEnvLoc, setUEnvRole,-  uType,--  ---------------------------------  -- Holes-  tcInfer,-  matchExpectedListTy,-  matchExpectedTyConApp,-  matchExpectedAppTy,-  matchExpectedFunTys,-  matchExpectedFunKind,-  matchActualFunTy, matchActualFunTys,--  checkTyEqRhs, recurseIntoTyConApp,-  PuResult(..), failCheckWith, okCheckRefl, mapCheck,-  TyEqFlags(..), TyEqFamApp(..), AreUnifying(..), LevelCheck(..), FamAppBreaker,-  famAppArgFlags,  checkPromoteFreeVars,-  simpleUnifyCheck, UnifyCheckCaller(..),--  fillInferResult,-  ) where--import GHC.Prelude--import GHC.Hs--import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, hasFixedRuntimeRep_syntactic )-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Instantiate-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.TcMType-import GHC.Tc.Utils.TcType-import GHC.Tc.Types.Evidence-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.CtLoc( CtLoc, mkKindEqLoc, adjustCtLoc )-import GHC.Tc.Types.Origin-import GHC.Tc.Zonk.TcType--import GHC.Core.Type-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.FVs( isInjectiveInType )-import GHC.Core.TyCo.Ppr( debugPprType {- pprTyVar -} )-import GHC.Core.TyCon-import GHC.Core.Coercion-import GHC.Core.Multiplicity-import GHC.Core.Reduction--import qualified GHC.LanguageExtensions as LangExt--import GHC.Builtin.Types-import GHC.Types.Name-import GHC.Types.Id( idType )-import GHC.Types.Var as Var-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Basic-import GHC.Types.Unique.Set (nonDetEltsUniqSet)--import GHC.Utils.Error-import GHC.Utils.Misc-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic--import GHC.Driver.DynFlags-import GHC.Data.Bag-import GHC.Data.FastString( fsLit )--import Control.Monad-import Data.Monoid as DM ( Any(..) )-import qualified Data.Semigroup as S ( (<>) )--{- *********************************************************************-*                                                                      *-              matchActualFunTys-*                                                                      *-********************************************************************* -}---- | 'matchActualFunTy' looks for just one function arrow,--- returning an uninstantiated sigma-type.------ Invariant: the returned argument type has a syntactically fixed--- RuntimeRep in the sense of Note [Fixed RuntimeRep]--- in GHC.Tc.Utils.Concrete.------ See Note [Return arguments with a fixed RuntimeRep].-matchActualFunTy-  :: ExpectedFunTyOrigin-      -- ^ See Note [Herald for matchExpectedFunTys]-  -> Maybe TypedThing-      -- ^ The thing with type TcSigmaType-  -> (Arity, TcType)-      -- ^ Total number of value args in the call, and-      --   the original function type-      -- (Both are used only for error messages)-  -> TcRhoType-      -- ^ Type to analyse: a TcRhoType-  -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)--- This function takes in a type to analyse (a RhoType) and returns--- an argument type and a result type (splitting apart a function arrow).--- The returned argument type is a SigmaType with a fixed RuntimeRep;--- as explained in Note [Return arguments with a fixed RuntimeRep].------ See Note [matchActualFunTy error handling] for the first three arguments---- If   (wrap, arg_ty, res_ty) = matchActualFunTy ... fun_ty--- then wrap :: fun_ty ~> (arg_ty -> res_ty)--- and NB: res_ty is an (uninstantiated) SigmaType--matchActualFunTy herald mb_thing err_info fun_ty-  = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $-    go fun_ty-  where-    -- Does not allocate unnecessary meta variables: if the input already is-    -- a function, we just take it apart.  Not only is this efficient,-    -- it's important for higher rank: the argument might be of form-    --              (forall a. ty) -> other-    -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd-    -- hide the forall inside a meta-variable-    go :: TcRhoType   -- The type we're processing, perhaps after-                      -- expanding type synonyms-       -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)-    go ty | Just ty' <- coreView ty = go ty'--    go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })-      = assert (isVisibleFunArg af) $-      do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty-         ; return (idHsWrapper, Scaled w arg_ty, res_ty) }--    go ty@(TyVarTy tv)-      | isMetaTyVar tv-      = do { cts <- readMetaTyVar tv-           ; case cts of-               Indirect ty' -> go ty'-               Flexi        -> defer ty }--       -- In all other cases we bale out into ordinary unification-       -- However unlike the meta-tyvar case, we are sure that the-       -- number of arguments doesn't match arity of the original-       -- type, so we can add a bit more context to the error message-       -- (cf #7869).-       ---       -- It is not always an error, because specialized type may have-       -- different arity, for example:-       ---       -- > f1 = f2 'a'-       -- > f2 :: Monad m => m Bool-       -- > f2 = undefined-       ---       -- But in that case we add specialized type into error context-       -- anyway, because it may be useful. See also #9605.-    go ty = addErrCtxtM (mk_ctxt ty) (defer ty)--    -------------    defer fun_ty-      = do { arg_ty <- new_check_arg_ty herald 1-           ; res_ty <- newOpenFlexiTyVarTy-           ; let unif_fun_ty = mkScaledFunTys [arg_ty] res_ty-           ; co <- unifyType mb_thing fun_ty unif_fun_ty-           ; return (mkWpCastN co, arg_ty, res_ty) }--    -------------    mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc)-    mk_ctxt _res_ty = mkFunTysMsg herald err_info--{- Note [matchActualFunTy error handling]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-matchActualFunTy is made much more complicated by the-desire to produce good error messages. Consider the application-    f @Int x y-In GHC.Tc.Gen.Head.tcInstFun we instantiate the function type, one-argument at a time.  It must instantiate any type/dictionary args,-before looking for an arrow type.--But if it doesn't find an arrow type, it wants to generate a message-like "f is applied to two arguments but its type only has one".-To do that, it needs to know about the args that tcArgs has already-munched up -- hence passing in n_val_args_in_call and arg_tys_so_far;-and hence also the accumulating so_far arg to 'go'.--This allows us (in mk_ctxt) to construct f's /instantiated/ type,-with just the values-arg arrows, which is what we really want-in the error message.--Ugh!--}---- | Like 'matchExpectedFunTys', but used when you have an "actual" type,--- for example in function application.------ INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep--- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.--- See Note [Return arguments with a fixed RuntimeRep].-matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys]-                  -> CtOrigin-                  -> Arity-                  -> TcSigmaType-                  -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType)--- If    matchActualFunTys n ty = (wrap, [t1,..,tn], res_ty)--- then  wrap : ty ~> (t1 -> ... -> tn -> res_ty)---       and res_ty is a RhoType--- NB: the returned type is top-instantiated; it's a RhoType-matchActualFunTys herald ct_orig n_val_args_wanted top_ty-  = go n_val_args_wanted [] top_ty-  where-    go n so_far fun_ty-      | not (isRhoTy fun_ty)-      = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty-           ; (wrap2, arg_tys, res_ty) <- go n so_far rho-           ; return (wrap2 <.> wrap1, arg_tys, res_ty) }--    go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)--    go n so_far fun_ty-      = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTy-                                                 herald Nothing-                                                 (n_val_args_wanted, top_ty)-                                                 fun_ty-           ; (wrap_res, arg_tys, res_ty)   <- go (n-1) (arg_ty1:so_far) res_ty1-           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty-           -- NB: arg_ty1 comes from matchActualFunTy, so it has-           -- a syntactically fixed RuntimeRep as needed to call mkWpFun.-           ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }--{--************************************************************************-*                                                                      *-          Skolemisation and matchExpectedFunTys-*                                                                      *-************************************************************************--Note [Skolemisation overview]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose f :: (forall a. a->a) -> blah, and we have the application (f e)-Then we want to typecheck `e` pushing in the type `forall a. a->a`. But we-need to be careful:--* Roughly speaking, in (tcPolyExpr e (forall a b. rho)), we skolemise `a` and `b`,-  and then call (tcExpr e rho)--* But not quite!  We must be careful if `e` is a type lambda (\ @p @q -> blah).-  Then we want to line up the skolemised variables `a`,`b`-  with `p`,`q`, so we can't just call (tcExpr (\ @p @q -> blah) rho)--* A very similar situation arises with-     (\ @p @q -> blah) :: forall a b. rho-  Again, we must line up `p`, `q` with the skolemised `a` and `b`.--* Another similar situation arises with-    g :: forall a b. rho-    g @p @q x y = ....-  Here again when skolemising `a` and `b` we must be careful to match them up-  with `p` and `q`.--OK, so how exactly do we check @p binders in lambdas?  First note that we only-we only attempt to deal with @p binders when /checking/. We don't do inference for-(\ @a -> blah), not yet anyway.--For checking, there are two cases to consider:-  * Function LHS, where the function has a type signature-                  f :: forall a. a -> forall b. [b] -> blah-                  f @p x @q y = ...--  * Lambda        \ @p x @q y -> ...-                  \cases { @p x @q y -> ... }-    (\case p behaves like \cases { p -> ... }, and p is always a term pattern.)--Both ultimately handled by matchExpectedFunTys.--* Function LHS case is handled by `GHC.Tc.Gen.Bind.tcPolyCheck`:-  * It calls `tcSkolemiseCompleteSig`-  * Passes the skolemised variables into `tcFunBindMatches`-  * Which uses `matchExpectedFunTys` to decompose the function type to-    match the arguments-  * And then passes the (skolemised-variables ++ arg tys) on to `tcMatches`--* For the Lambda case there are two sub-cases:-   * An expression with a type signature: (\ @a x y -> blah) :: hs_ty-     This is handled by `GHC.Tc.Gen.Head.tcExprWithSig`, which kind-checks-     the signature and hands off to `tcExprPolyCheck` vai `tcPolyLExprSig`-     Note that the foralls at the top of hs_ty scope over the expression.--   * A higher order call: h e, where h :: poly_ty -> blah-     This is handlded by `GHC.Tc.Gen.Expr.tcPolyExpr`, which (in the-     checking case) again hands off to `tcExprPolyCheck`.  Here there is-     no type-variable scoping to worry about.--  So both sub-cases end up in `GHC.Tc.Gen.Expr.tcPolyExprCheck`-  * This skolemises the /top-level/ invisible binders, but remembers-    the binders as [ExpPatType]-  * Then it looks for a lambda, and if so, calls `tcLambdaMatches` passing in-    the skolemised binders so they can be matched up with the lambda binders.-  * Otherwise it does deep-skolemisation if DeepSubsumption is on,-    and then calls tcExpr to typecheck `e`--  The outer skolemisation in tcPolyExprCheck is done using-    * tcSkolemiseCompleteSig when there is a user-written signature-    * tcSkolemiseGeneral when the polytype just comes from the context e.g. (f e)-  The former just calls the latter, so the two cases differ only slightly:-    * Both do shallow skolemisation-    * Both go via checkConstraints, which uses implicationNeeded to decide whether-      to build an implication constraint even if there /are/ no skolems.-      See Note [When to build an implication] below.--  The difference between the two cases is that `tcSkolemiseCompleteSig`-  also brings the outer type variables into scope.  It would do no-  harm to do so in both cases, but I found that (to my surprise) doing-  so caused a non-trivial (1%-ish) perf hit on the compiler.--* `tcFunBindMatches` and `tcLambdaMatches` both use `matchExpectedFunTys`, which-  ensures that any trailing invisible binders are skolemised; and does so deeply-  if DeepSubsumption is on.--  This corresponds to the plan: "skolemise at the '=' of a function binding or-  at the '->' of a lambda binding".  (See #17594 and "Plan B2".)--Some wrinkles--(SK1) tcSkolemiseGeneral and tcSkolemiseCompleteSig make fresh type variables-      See Note [Instantiate sig with fresh variables]--(SK2) All skolemisation (even without DeepSubsumption) builds just one implication-      constraint for a nested forall like:-          forall a. Eq a => forall b. Ord b => blah-      The implication constraint will look like-          forall a b. (Eq a, Ord b) => <constraints>-      See the loop in GHC.Tc.Utils.Instantiate.topSkolemise.-      and Note [Skolemisation en-bloc] in that module---Some examples:--*     f :: forall a b. blah-      f @p x = rhs-  `tcPolyCheck` calls `tcSkolemiseCompleteSig` to skolemise the signature, and-  then calls `tcFunBindMatches` passing in [a_sk, b_sk], the skolemsed-  variables. The latter ultimately calls `tcMatches`, and thence `tcMatchPats`.-  The latter matches up the `a_sk` with `@p`, and discards the `b_sk`.--*     f :: forall (a::Type) (b::a). blah-      f @(p::b) x = rhs-  `tcSkolemiseCompleteSig` brings `a` and `b` into scope, bound to `a_sk` and `b_sk` resp.-  When `tcMatchPats` typechecks the pattern `@(p::b)` it'll find that `b` is in-  scope (as a result of tcSkolemiseCompleteSig) which is a bit strange.  But-  it'll then unify the kinds `Type ~ b`, which will fail as it should.--*     f :: Int -> forall (a::Type) (b::a). blah-      f x  @p = rhs-  `matchExpectedFunTys` does shallow skolemisation eagerly, so we'll skolemise the-  forall a b.  Then `tcMatchPats` will bind [p :-> a_sk], and discard `b_sk`.-  Discarding the `b_sk` means that-      f x @p = \ @q -> blah-  or  f x @p = let .. in \ @q -> blah-  will both be rejected: this is Plan B2: skolemise at the "=".--* Suppose DeepSubsumption is on-    f :: forall a. a -> forall b. b -> b -> forall z. z-    f @p x @q y = rhs-  The `tcSkolemiseCompleteSig` uses shallow skolemisation, so it only skolemises-  and brings into scope [a :-> a_sk]. Then `matchExpectedFunTys` skolemises the-  forall b, because it needs to expose two value arguments.  Finally-  `matchExpectedFunTys` concludes with deeply skolemising the remaining type.--  So we end up with `[p :-> a_sk, q :-> b_sk]`.  Notice that we must not-  deeply-skolemise /first/ or we'd get the tyvars [a_sk, b_sk, c_sk] which would-  not line up with the patterns [@p, x, @q, y]--}--tcSkolemiseGeneral-  :: DeepSubsumptionFlag-  -> UserTypeCtxt-  -> TcType -> TcType   -- top_ty and expected_ty-        -- Here, top_ty      is the type we started to skolemise; used only in SigSkol-        -- -     expected_ty is the type we are actually skolemising-        -- matchExpectedFunTys walks down the type, skolemising as it goes,-        -- keeping the same top_ty, but successively smaller expected_tys-  -> ([(Name, TcInvisTVBinder)] -> TcType -> TcM result)-  -> TcM (HsWrapper, result)-tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside-  | isRhoTyDS ds_flag expected_ty-    -- Fast path for a very very common case: no skolemisation to do-    -- But still call checkConstraints in case we need an implication regardless-  = do { let sig_skol = SigSkol ctxt top_ty []-       ; (ev_binds, result) <- checkConstraints sig_skol [] [] $-                               thing_inside [] expected_ty-       ; return (mkWpLet ev_binds, result) }--  | otherwise-  = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]-         --           in GHC.Tc.Utils.TcType-       ; rec { (wrap, tv_prs, given, rho_ty) <- case ds_flag of-                    Deep    -> deeplySkolemise skol_info expected_ty-                    Shallow -> topSkolemise skol_info expected_ty-             ; let sig_skol = SigSkol ctxt top_ty (map (fmap binderVar) tv_prs)-             ; skol_info <- mkSkolemInfo sig_skol }--       ; let skol_tvs = map (binderVar . snd) tv_prs-       ; traceTc "tcSkolemiseGeneral" (pprUserTypeCtxt ctxt <+> ppr skol_tvs <+> ppr given)-       ; (ev_binds, result) <- checkConstraints sig_skol skol_tvs given $-                               thing_inside tv_prs rho_ty--       ; return (wrap <.> mkWpLet ev_binds, result) }-         -- The ev_binds returned by checkConstraints is very-         -- often empty, in which case mkWpLet is a no-op--tcSkolemiseCompleteSig :: TcCompleteSig-                       -> ([ExpPatType] -> TcRhoType -> TcM result)-                       -> TcM (HsWrapper, result)--- ^ The wrapper has type: spec_ty ~> expected_ty--- See Note [Skolemisation] for the differences between--- tcSkolemiseCompleteSig and tcTopSkolemise--tcSkolemiseCompleteSig (CSig { sig_bndr = poly_id, sig_ctxt = ctxt, sig_loc = loc })-                       thing_inside-  = do { cur_loc <- getSrcSpanM-       ; let poly_ty = idType poly_id-       ; setSrcSpan loc $   -- Sets the location for the implication constraint-         tcSkolemiseGeneral Shallow ctxt poly_ty poly_ty $ \tv_prs rho_ty ->-         setSrcSpan cur_loc $ -- Revert to the original location-         tcExtendNameTyVarEnv (map (fmap binderVar) tv_prs) $-         thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty }--tcSkolemiseExpectedType :: TcSigmaType-                        -> ([ExpPatType] -> TcRhoType -> TcM result)-                        -> TcM (HsWrapper, result)--- Just like tcSkolemiseCompleteSig, except that we don't have a user-written--- type signature, we only have a type comimg from the context.--- Eg. f :: (forall a. blah) -> blah---     In the call (f e) we will call tcSkolemiseExpectedType on (forall a.blah)---     before typececking `e`-tcSkolemiseExpectedType exp_ty thing_inside-  = tcSkolemiseGeneral Shallow GenSigCtxt exp_ty exp_ty $ \tv_prs rho_ty ->-    thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty--tcSkolemise :: DeepSubsumptionFlag -> UserTypeCtxt -> TcSigmaType-            -> (TcRhoType -> TcM result)-            -> TcM (HsWrapper, result)-tcSkolemise ds_flag ctxt expected_ty thing_inside-  = tcSkolemiseGeneral ds_flag ctxt expected_ty expected_ty $ \_ rho_ty ->-    thing_inside rho_ty--checkConstraints :: SkolemInfoAnon-                 -> [TcTyVar]           -- Skolems-                 -> [EvVar]             -- Given-                 -> TcM result-                 -> TcM (TcEvBinds, result)--- checkConstraints is careful to build an implication even if--- `skol_tvs` and `given` are both empty, under certain circumstances--- See Note [When to build an implication]-checkConstraints skol_info skol_tvs given thing_inside-  = do { implication_needed <- implicationNeeded skol_info skol_tvs given--       ; if implication_needed-         then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside-                 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted-                 ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)-                 ; emitImplications implics-                 ; return (ev_binds, result) }--         else -- Fast path.  We check every function argument with tcCheckPolyExpr,-              -- which uses tcTopSkolemise and hence checkConstraints.-              -- So this fast path is well-exercised-              do { res <- thing_inside-                 ; return (emptyTcEvBinds, res) } }--checkTvConstraints :: SkolemInfo-                   -> [TcTyVar]          -- Skolem tyvars-                   -> TcM result-                   -> TcM result--checkTvConstraints skol_info skol_tvs thing_inside-  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside-       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted-       ; return result }--emitResidualTvConstraint :: SkolemInfo -> [TcTyVar]-                         -> TcLevel -> WantedConstraints -> TcM ()-emitResidualTvConstraint skol_info skol_tvs tclvl wanted-  | not (isEmptyWC wanted) ||-    checkTelescopeSkol skol_info_anon-  = -- checkTelescopeSkol: in this case, /always/ emit this implication-    -- even if 'wanted' is empty. We need the implication so that we check-    -- for a bad telescope. See Note [Skolem escape and forall-types] in-    -- GHC.Tc.Gen.HsType-    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted-       ; emitImplication implic }--  | otherwise  -- Empty 'wanted', emit nothing-  = return ()-  where-     skol_info_anon = getSkolemInfo skol_info--buildTvImplication :: SkolemInfoAnon -> [TcTyVar]-                   -> TcLevel -> WantedConstraints -> TcM Implication-buildTvImplication skol_info skol_tvs tclvl wanted-  = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $-    do { ev_binds <- newNoTcEvBinds  -- Used for equalities only, so all the constraints-                                     -- are solved by filling in coercion holes, not-                                     -- by creating a value-level evidence binding-       ; implic   <- newImplication--       ; let implic' = implic { ic_tclvl     = tclvl-                              , ic_skols     = skol_tvs-                              , ic_given_eqs = NoGivenEqs-                              , ic_wanted    = wanted-                              , ic_binds     = ev_binds-                              , ic_info      = skol_info }--       ; checkImplicationInvariants implic'-       ; return implic' }--implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool--- See Note [When to build an implication]-implicationNeeded skol_info skol_tvs given-  | null skol_tvs-  , null given-  , not (alwaysBuildImplication skol_info)-  = -- Empty skolems and givens-    do { tc_lvl <- getTcLevel-       ; if not (isTopTcLevel tc_lvl)  -- No implication needed if we are-         then return False             -- already inside an implication-         else-    do { dflags <- getDynFlags       -- If any deferral can happen,-                                     -- we must build an implication-       ; return (gopt Opt_DeferTypeErrors dflags ||-                 gopt Opt_DeferTypedHoles dflags ||-                 gopt Opt_DeferOutOfScopeVariables dflags) } }--  | otherwise     -- Non-empty skolems or givens-  = return True   -- Definitely need an implication--alwaysBuildImplication :: SkolemInfoAnon -> Bool--- See Note [When to build an implication]-alwaysBuildImplication _ = False--{-  Commmented out for now while I figure out about error messages.-    See #14185--alwaysBuildImplication (SigSkol ctxt _ _)-  = case ctxt of-      FunSigCtxt {} -> True  -- RHS of a binding with a signature-      _             -> False-alwaysBuildImplication (RuleSkol {})      = True-alwaysBuildImplication (InstSkol {})      = True-alwaysBuildImplication (FamInstSkol {})   = True-alwaysBuildImplication _                  = False--}--buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar]-                   -> [EvVar] -> WantedConstraints-                   -> TcM (Bag Implication, TcEvBinds)-buildImplicationFor tclvl skol_info skol_tvs given wanted-  | isEmptyWC wanted && null given-             -- Optimisation : if there are no wanteds, and no givens-             -- don't generate an implication at all.-             -- Reason for the (null given): we don't want to lose-             -- the "inaccessible alternative" error check-  = return (emptyBag, emptyTcEvBinds)--  | otherwise-  = 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,-      -- because TyVarTvs will always remain tyvars, even after unification.-    do { ev_binds_var <- newTcEvBinds-       ; implic <- newImplication-       ; let implic' = implic { ic_tclvl  = tclvl-                              , ic_skols  = skol_tvs-                              , ic_given  = given-                              , ic_wanted = wanted-                              , ic_binds  = ev_binds_var-                              , ic_info   = skol_info }-       ; checkImplicationInvariants implic'--       ; return (unitBag implic', TcEvBinds ev_binds_var) }--{- Note [When to build an implication]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have some 'skolems' and some 'givens', and we are-considering whether to wrap the constraints in their scope into an-implication.  We must /always/ do so if either 'skolems' or 'givens' are-non-empty.  But what if both are empty?  You might think we could-always drop the implication.  Other things being equal, the fewer-implications the better.  Less clutter and overhead.  But we must-take care:--* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,-  we'll make a /term-level/ evidence binding for 'g = error "blah"'.-  We must have an EvBindsVar those bindings!, otherwise they end up as-  top-level unlifted bindings, which are verboten. This only matters-  at top level, so we check for that-  See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors.-  cf #14149 for an example of what goes wrong.--* This is /necessary/ for top level but may be /desirable/ even for-  nested bindings, because if the deferred coercion is bound too far-  out it will be reported even if that thunk (say) is not evaluated.--* If you have-     f :: Int;  f = f_blah-     g :: Bool; g = g_blah-  If we don't build an implication for f or g (no tyvars, no givens),-  the constraints for f_blah and g_blah are solved together.  And that-  can yield /very/ confusing error messages, because we can get-      [W] C Int b1    -- from f_blah-      [W] C Int b2    -- from g_blan-  and fundeps can yield [W] b1 ~ b2, even though the two functions have-  literally nothing to do with each other.  #14185 is an example.-  Building an implication keeps them separate.--Note [Herald for matchExpectedFunTys]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The 'herald' always looks like:-   "The equation(s) for 'f' have"-   "The abstraction (\x.e) takes"-   "The section (+ x) expects"-   "The function 'f' is applied to"--This is used to construct a message of form--   The abstraction `\Just 1 -> ...' takes two arguments-   but its type `Maybe a -> a' has only one--   The equation(s) for `f' have two arguments-   but its type `Maybe a -> a' has only one--   The section `(f 3)' requires 'f' to take two arguments-   but its type `Int -> Int' has only one--   The function 'f' is applied to two arguments-   but its type `Int -> Int' has only one--When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the-picture, we have a choice in deciding whether to count the type applications as-proper arguments:--   The function 'f' is applied to one visible type argument-     and two value arguments-   but its type `forall a. a -> a` has only one visible type argument-     and one value argument--Or whether to include the type applications as part of the herald itself:--   The expression 'f @Int' is applied to two arguments-   but its type `Int -> Int` has only one--The latter is easier to implement and is arguably easier to understand, so we-choose to implement that option.--Note [matchExpectedFunTys]-~~~~~~~~~~~~~~~~~~~~~~~~~~-matchExpectedFunTys checks that a sigma has the form-of an n-ary function.  It passes the decomposed type to the-thing_inside, and returns a wrapper to coerce between the two types--It's used wherever a language construct must have a functional type,-namely:-        A lambda expression-        A function definition-     An operator section--This function must be written CPS'd because it needs to fill in the-ExpTypes produced for arguments before it can fill in the ExpType-passed in.--Note [Return arguments with a fixed RuntimeRep]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The functions--  - matchExpectedFunTys,-  - matchActualFunTy,-  - matchActualFunTys,--peel off argument types, as explained in Note [matchExpectedFunTys].-It's important that these functions return argument types that have-a fixed runtime representation, otherwise we would be in violation-of the representation-polymorphism invariants of-Note [Representation polymorphism invariants] in GHC.Core.--This is why all these functions have an additional invariant,-that the argument types they return all have a syntactically fixed RuntimeRep,-in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.--Example:--  Suppose we have--    type F :: Type -> RuntimeRep-    type family F a where { F Int = LiftedRep }--    type Dual :: Type -> Type-    type family Dual a where-      Dual a = a -> ()--    f :: forall (a :: TYPE (F Int)). Dual a-    f = \ x -> ()--  The body of `f` is a lambda abstraction, so we must be able to split off-  one argument type from its type. This is handled by `matchExpectedFunTys`-  (see 'GHC.Tc.Gen.Match.tcLambdaMatches'). We end up with desugared Core that-  looks like this:--    f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0]))-    f = \ @(a :: TYPE (F Int)) ->-          (\ (x :: (a |> (TYPE F[0]))) -> ())-          `cast`-          (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>)))--  Two important transformations took place:--    1. We inserted casts around the argument type to ensure that it has-       a fixed runtime representation, as required by invariant (I1) from-       Note [Representation polymorphism invariants] in GHC.Core.-    2. We inserted a cast around the whole lambda to make everything line up-       with the type signature.--}---- | Use this function to split off arguments types when you have an--- \"expected\" type.------ This function skolemises at each polytype.------ Invariant: this function only applies the provided function--- to a list of argument types which all have a syntactically fixed RuntimeRep--- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.--- See Note [Return arguments with a fixed RuntimeRep].-matchExpectedFunTys :: forall a.-                       ExpectedFunTyOrigin  -- See Note [Herald for matchExpectedFunTys]-                    -> UserTypeCtxt-                    -> VisArity-                    -> ExpSigmaType-                    -> ([ExpPatType] -> ExpRhoType -> TcM a)-                    -> TcM (HsWrapper, a)--- If    matchExpectedFunTys n ty = (wrap, _)--- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,---   where [t1, ..., tn], ty_r are passed to the thing_inside------ Unconditionally concludes by skolemising any trailing invisible--- binders and, if DeepSubsumption is on, it does so deeply.------ Postcondition:---   If exp_ty is Check {}, then [ExpPatType] and ExpRhoType results are all Check{}---   If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{}-matchExpectedFunTys herald _ arity (Infer inf_res) thing_inside-  = do { arg_tys <- mapM (new_infer_arg_ty herald) [1 .. arity]-       ; res_ty  <- newInferExpType-       ; result  <- thing_inside (map ExpFunPatTy arg_tys) res_ty-       ; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys-       ; res_ty  <- readExpType res_ty-       ; co <- fillInferResult (mkScaledFunTys arg_tys res_ty) inf_res-       ; return (mkWpCastN co, result) }--matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside-  = check arity [] top_ty-  where-    check :: VisArity -> [ExpPatType] -> TcSigmaType -> TcM (HsWrapper, a)-    -- `check` is called only in the Check{} case-    -- It collects rev_pat_tys in reversed order-    -- n_req is the number of /visible/ arguments still needed--    -----------------------------    -- Skolemise quantifiers, both visible (up to n_req) and invisible-    -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App-    check n_req rev_pat_tys ty-      | isSigmaTy ty                     -- An invisible quantifier at the top-        || (n_req > 0 && isForAllTy ty)  -- A visible quantifier at top, and we need it-      = do { rec { (n_req', wrap_gen, tv_nms, bndrs, given, inner_ty) <- skolemiseRequired skol_info n_req ty-                 ; let sig_skol = SigSkol ctx top_ty (tv_nms `zip` skol_tvs)-                       skol_tvs = binderVars bndrs-                 ; skol_info <- mkSkolemInfo sig_skol }-             -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]-             --           in GHC.Tc.Utils.TcType-           ; (ev_binds, (wrap_res, result))-                  <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $-                     check n_req'-                           (reverse (map ExpForAllPatTy bndrs) ++ rev_pat_tys)-                           inner_ty-           ; assertPpr (not (null bndrs && null given)) (ppr ty) $-                       -- The guard ensures that we made some progress-             return (wrap_gen <.> mkWpLet ev_binds <.> wrap_res, result) }--    -----------------------------    -- Base case: (n_req == 0): no more args-    --    The earlier skolemisation ensurs that rho_ty has no top-level invisible quantifiers-    --    If there is deep subsumption, do deep skolemisation now-    check n_req rev_pat_tys rho_ty-      | n_req == 0-      = do { let pat_tys = reverse rev_pat_tys-           ; ds_flag <- getDeepSubsumptionFlag-           ; case ds_flag of-               Shallow -> do { res <- thing_inside pat_tys (mkCheckExpType rho_ty)-                             ; return (idHsWrapper, res) }-               Deep    -> tcSkolemiseGeneral Deep ctx top_ty rho_ty $ \_ rho_ty ->-                          -- "_" drop the /deeply/-skolemise binders-                          -- They do not line up with binders in the Match-                          thing_inside pat_tys (mkCheckExpType rho_ty) }--    -----------------------------    -- Function types-    check n_req rev_pat_tys (FunTy { ft_af = af, ft_mult = mult-                                   , ft_arg = arg_ty, ft_res = res_ty })-      = assert (isVisibleFunArg af) $-        do { let arg_pos = arity - n_req + 1   -- 1 for the first argument etc-           ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty-           ; (wrap_res, result) <- check (n_req - 1)-                                         (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys)-                                         res_ty-           ; let wrap_arg = mkWpCastN arg_co-                 fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty-           ; return (fun_wrap, result) }--    -----------------------------    -- Type variables-    check n_req rev_pat_tys ty@(TyVarTy tv)-      | isMetaTyVar tv-      = do { cts <- readMetaTyVar tv-           ; case cts of-               Indirect ty' -> check n_req rev_pat_tys ty'-               Flexi        -> defer n_req rev_pat_tys ty }--    -----------------------------    -- NOW do coreView.  We didn't do it before, so that we do not unnecessarily-    -- unwrap a synonym in the returned rho_ty-    check n_req rev_pat_tys ty-      | Just ty' <- coreView ty = check n_req rev_pat_tys ty'--       -- In all other cases we bale out into ordinary unification-       -- However unlike the meta-tyvar case, we are sure that the-       -- number of arguments doesn't match arity of the original-       -- type, so we can add a bit more context to the error message-       -- (cf #7869).-       ---       -- It is not always an error, because specialized type may have-       -- different arity, for example:-       ---       -- > f1 = f2 'a'-       -- > f2 :: Monad m => m Bool-       -- > f2 = undefined-       ---       -- But in that case we add specialized type into error context-       -- anyway, because it may be useful. See also #9605.-    check n_req rev_pat_tys res_ty-      = addErrCtxtM (mkFunTysMsg herald (arity, top_ty))  $-        defer n_req rev_pat_tys res_ty--    -------------    defer :: VisArity -> [ExpPatType] -> TcRhoType -> TcM (HsWrapper, a)-    defer n_req rev_pat_tys fun_ty-      = do { more_arg_tys <- mapM (new_check_arg_ty herald) [arity - n_req + 1 .. arity]-           ; let all_pats = reverse rev_pat_tys ++ map mkCheckExpFunPatTy more_arg_tys-           ; res_ty <- newOpenFlexiTyVarTy-           ; result <- thing_inside all_pats (mkCheckExpType res_ty)--           ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty-           ; return (mkWpCastN co, result) }--new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR)-new_infer_arg_ty herald arg_pos -- position for error messages only-  = do { mult     <- newFlexiTyVarTy multiplicityTy-       ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)-       ; return (mkScaled mult inf_hole) }--new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType)-new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg-  = do { mult   <- newFlexiTyVarTy multiplicityTy-       ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos)-       ; return (mkScaled mult arg_ty) }--mkFunTysMsg :: ExpectedFunTyOrigin-            -> (VisArity, TcType)-            -> TidyEnv -> ZonkM (TidyEnv, SDoc)--- See Note [Reporting application arity errors]-mkFunTysMsg herald (n_vis_args_in_call, fun_ty) env-  = do { (env', fun_ty) <- zonkTidyTcType env fun_ty--       ; let (pi_ty_bndrs, _) = splitPiTys fun_ty-             n_fun_args = count isVisiblePiTyBinder pi_ty_bndrs-             msg | n_vis_args_in_call <= n_fun_args  -- Enough args, in the end-                 = text "In the result of a function call"-                 | otherwise-                 = hang (full_herald <> comma)-                      2 (sep [ text "but its type" <+> quotes (pprSigmaType fun_ty)-                             , if n_fun_args == 0 then text "has none"-                               else text "has only" <+> speakN n_fun_args])--       ; return (env', msg) }- where-  full_herald = pprExpectedFunTyHerald herald-            <+> speakNOf n_vis_args_in_call (text "visible argument")-             -- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic---{- Note [Reporting application arity errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider      f :: Int -> Int -> Int-and the call  foo = f 3 4 5-We'd like to get an error like:--    • Couldn't match expected type ‘t0 -> t’ with actual type ‘Int’-    • The function ‘f’ is applied to three visible arguments,           -- What are "visible" arguments?-        but its type ‘Int -> Int -> Int’ has only two                   -- See Note [Visibility and arity] in GHC.Types.Basic--That is what `mkFunTysMsg` tries to do.  But what is the "type of the function".-Most obviously, we can report its full, polymorphic type; that is simple and-explicable.  But sometimes a bit odd.  Consider-    f :: Bool -> t Int Int-    foo = f True 5 10-We get this error:-    • Couldn't match type ‘Int’ with ‘t0 -> t’-      Expected: Int -> t0 -> t-        Actual: Int -> Int-    • The function ‘f’ is applied to three visible arguments,-        but its type ‘Bool -> t Int Int’ has only one--That's not /quite/ right beause we can instantiate `t` to an arrow and get-two arrows (but not three!).  With that in mind, one could consider reporting-the /instantiated/ type, and GHC used to do so.  But it's more work, and in-some ways more confusing, especially when nested quantifiers are concerned, e.g.-    f :: Bool -> forall t. t Int Int--So we just keep it simple and report the original function type.---************************************************************************-*                                                                      *-                    Other matchExpected functions-*                                                                      *-********************************************************************* -}--matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)--- Special case for lists-matchExpectedListTy exp_ty- = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty-      ; return (co, elt_ty) }------------------------matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *-                      -> TcRhoType            -- orig_ty-                      -> TcM (TcCoercionN,    -- T k1 k2 k3 a b c ~N orig_ty-                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c---- It's used for wired-in tycons, so we call checkWiredInTyCon--- Precondition: never called with FunTyCon--- Precondition: input type :: *--- Postcondition: (T k1 k2 k3 a b c) is well-kinded--matchExpectedTyConApp tc orig_ty-  = assertPpr (isAlgTyCon tc) (ppr tc) $-    go orig_ty-  where-    go ty-       | Just ty' <- coreView ty-       = go ty'--    go ty@(TyConApp tycon args)-       | tc == tycon  -- Common case-       = return (mkNomReflCo ty, args)--    go (TyVarTy tv)-       | isMetaTyVar tv-       = do { cts <- readMetaTyVar tv-            ; case cts of-                Indirect ty -> go ty-                Flexi       -> defer }--    go _ = defer--    -- If the common case does not occur, instantiate a template-    -- T k1 .. kn t1 .. tm, and unify with the original type-    -- Doing it this way ensures that the types we return are-    -- kind-compatible with T.  For example, suppose we have-    --       matchExpectedTyConApp T (f Maybe)-    -- where data T a = MkT a-    -- Then we don't want to instantiate T's data constructors with-    --    (a::*) ~ Maybe-    -- because that'll make types that are utterly ill-kinded.-    -- This happened in #7368-    defer-      = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)-           ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)-           ; let args = mkTyVarTys arg_tvs-                 tc_template = mkTyConApp tc args-           ; co <- unifyType Nothing tc_template orig_ty-           ; return (co, args) }-------------------------matchExpectedAppTy :: TcRhoType                         -- orig_ty-                   -> TcM (TcCoercion,                   -- m a ~N orig_ty-                           (TcSigmaType, TcSigmaType))  -- Returns m, a--- If the incoming type is a mutable type variable of kind k, then--- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.--matchExpectedAppTy orig_ty-  = go orig_ty-  where-    go ty-      | Just ty' <- coreView ty = go ty'--      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty-      = return (mkNomReflCo orig_ty, (fun_ty, arg_ty))--    go (TyVarTy tv)-      | isMetaTyVar tv-      = do { cts <- readMetaTyVar tv-           ; case cts of-               Indirect ty -> go ty-               Flexi       -> defer }--    go _ = defer--    -- Defer splitting by generating an equality constraint-    defer-      = do { ty1 <- newFlexiTyVarTy kind1-           ; ty2 <- newFlexiTyVarTy kind2-           ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty-           ; return (co, (ty1, ty2)) }--    orig_kind = typeKind orig_ty-    kind1 = mkVisFunTyMany liftedTypeKind orig_kind-    kind2 = liftedTypeKind    -- m :: * -> k-                              -- arg type :: *--{- **********************************************************************-*-                      fillInferResult-*-********************************************************************** -}--{- Note [inferResultToType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-expTypeToType and inferResultType convert an InferResult to a monotype.-It must be a monotype because if the InferResult isn't already filled in,-we fill it in with a unification variable (hence monotype).  So to preserve-order-independence we check for mono-type-ness even if it *is* filled in-already.--See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and-Note [fillInferResult].--}---- | Fill an 'InferResult' with the given type.------ If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@,--- where @t2@ is the type stored in the 'ir_ref' field of @infer_res@.------ This function enforces the following invariants:------  - Level invariant.---    The stored type @t2@ is at the same level as given by the---    'ir_lvl' field.---  - FRR invariant.---    Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed---    to have a syntactically fixed RuntimeRep, in the sense of---    Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.-fillInferResult :: TcType -> InferResult -> TcM TcCoercionN-fillInferResult act_res_ty (IR { ir_uniq = u-                               , ir_lvl  = res_lvl-                               , ir_frr  = mb_frr-                               , ir_ref  = ref })-  = do { mb_exp_res_ty <- readTcRef ref-       ; case mb_exp_res_ty of-            Just exp_res_ty-               -- We progressively refine the type stored in 'ref',-               -- for example when inferring types across multiple equations.-               ---               -- Example:-               ---               --  \ x -> case y of { True -> x ; False -> 3 :: Int }-               ---               -- When inferring the return type of this function, we will create-               -- an 'Infer' 'ExpType', which will first be filled by the type of 'x'-               -- after typechecking the first equation, and then filled again with-               -- the type 'Int', at which point we want to ensure that we unify-               -- the type of 'x' with 'Int'. This is what is happening below when-               -- we are "joining" several inferred 'ExpType's.-               -> do { traceTc "Joining inferred ExpType" $-                       ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty-                     ; cur_lvl <- getTcLevel-                     ; unless (cur_lvl `sameDepthAs` res_lvl) $-                       ensureMonoType act_res_ty-                     ; unifyType Nothing act_res_ty exp_res_ty }-            Nothing-               -> do { traceTc "Filling inferred ExpType" $-                       ppr u <+> text ":=" <+> ppr act_res_ty--                     -- Enforce the level invariant: ensure the TcLevel of-                     -- the type we are writing to 'ref' matches 'ir_lvl'.-                     ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty--                     -- Enforce the FRR invariant: ensure the type has a syntactically-                     -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing').-                     ; (frr_co, act_res_ty) <--                         case mb_frr of-                           Nothing       -> return (mkNomReflCo act_res_ty, act_res_ty)-                           Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty--                     -- Compose the two coercions.-                     ; let final_co = prom_co `mkTransCo` frr_co--                     ; writeTcRef ref (Just act_res_ty)--                     ; return final_co }-     }--{- Note [fillInferResult]-~~~~~~~~~~~~~~~~~~~~~~~~~-When inferring, we use fillInferResult to "fill in" the hole in InferResult-   data InferResult = IR { ir_uniq :: Unique-                         , ir_lvl  :: TcLevel-                         , ir_ref  :: IORef (Maybe TcType) }--There are two things to worry about:--1. What if it is under a GADT or existential pattern match?-   - GADTs: a unification variable (and Infer's hole is similar) is untouchable-   - Existentials: be careful about skolem-escape--2. What if it is filled in more than once?  E.g. multiple branches of a case-     case e of-        T1 -> e1-        T2 -> e2--Our typing rules are:--* The RHS of a existential or GADT alternative must always be a-  monotype, regardless of the number of alternatives.--* Multiple non-existential/GADT branches can have (the same)-  higher rank type (#18412).  E.g. this is OK:-      case e of-        True  -> hr-        False -> hr-  where hr:: (forall a. a->a) -> Int-  c.f. Section 7.1 of "Practical type inference for arbitrary-rank types"-       We use choice (2) in that Section.-       (GHC 8.10 and earlier used choice (1).)--  But note that-      case e of-        True  -> hr-        False -> \x -> hr x-  will fail, because we still /infer/ both branches, so the \x will get-  a (monotype) unification variable, which will fail to unify with-  (forall a. a->a)--For (1) we can detect the GADT/existential situation by seeing that-the current TcLevel is greater than that stored in ir_lvl of the Infer-ExpType.  We bump the level whenever we go past a GADT/existential match.--Then, before filling the hole use promoteTcType to promote the type-to the outer ir_lvl.  promoteTcType does this-  - create a fresh unification variable alpha at level ir_lvl-  - emits an equality alpha[ir_lvl] ~ ty-  - fills the hole with alpha-That forces the type to be a monotype (since unification variables can-only unify with monotypes); and catches skolem-escapes because the-alpha is untouchable until the equality floats out.--For (2), we simply look to see if the hole is filled already.-  - if not, we promote (as above) and fill the hole-  - if it is filled, we simply unify with the type that is-    already there--There is one wrinkle.  Suppose we have-   case e of-      T1 -> e1 :: (forall a. a->a) -> Int-      G2 -> e2-where T1 is not GADT or existential, but G2 is a GADT.  Then suppose the-T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.-But now the G2 alternative must not *just* unify with that else we'd risk-allowing through (e2 :: (forall a. a->a) -> Int).  If we'd checked G2 first-we'd have filled the hole with a unification variable, which enforces a-monotype.--So if we check G2 second, we still want to emit a constraint that restricts-the RHS to be a monotype. This is done by ensureMonoType, and it works-by simply generating a constraint (alpha ~ ty), where alpha is a fresh-unification variable.  We discard the evidence.---}----{--************************************************************************-*                                                                      *-                Subsumption checking-*                                                                      *-************************************************************************--Note [Subsumption checking: tcSubType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-All the tcSubType calls have the form-                tcSubType actual_ty expected_ty-which checks-                actual_ty <= expected_ty--That is, that a value of type actual_ty is acceptable in-a place expecting a value of type expected_ty.  I.e. that--    actual ty   is more polymorphic than   expected_ty--It returns a wrapper function-        co_fn :: actual_ty ~ expected_ty-which takes an HsExpr of type actual_ty into one of type-expected_ty.--Note [Ambiguity check and deep subsumption]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f :: (forall b. Eq b => a -> a) -> Int--Does `f` have an ambiguous type?   The ambiguity check usually checks-that this definition of f' would typecheck, where f' has the exact same-type as f:-   f' :: (forall b. Eq b => a -> a) -> Intp-   f' = f--This will be /rejected/ with DeepSubsumption but /accepted/ with-ShallowSubsumption.  On the other hand, this eta-expanded version f''-would be rejected both ways:-   f'' :: (forall b. Eq b => a -> a) -> Intp-   f'' x = f x--This is squishy in the same way as other examples in GHC.Tc.Validity-Note [The squishiness of the ambiguity check]--The situation in June 2022.  Since we have SimpleSubsumption at the moment,-we don't want introduce new breakage if you add -XDeepSubsumption, by-rejecting types as ambiguous that weren't ambiguous before.  So, as a-holding decision, we /always/ use SimpleSubsumption for the ambiguity check-(erring on the side accepting more programs). Hence tcSubTypeAmbiguity.--}------------------------ tcWrapResult needs both un-type-checked (for origins and error messages)--- and type-checked (for wrapping) expressions-tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType-             -> TcM (HsExpr GhcTc)-tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr--tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType-               -> TcM (HsExpr GhcTc)-tcWrapResultO orig rn_expr expr actual_ty res_ty-  = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty-                                      , text "Expected:" <+> ppr res_ty ])-       ; wrap <- tcSubTypeNC orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty-       ; return (mkHsWrap wrap expr) }--tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc-                 -> TcRhoType   -- Actual -- a rho-type not a sigma-type-                 -> ExpRhoType  -- Expected-                 -> TcM (HsExpr GhcTc)--- A version of tcWrapResult to use when the actual type is a--- 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-  = assertPpr (isRhoTy act_ty) (ppr act_ty $$ ppr rn_expr) $-    do { co <- unifyExpectedType rn_expr act_ty res_ty-       ; return (mkHsWrapCo co expr) }--unifyExpectedType :: HsExpr GhcRn-                  -> TcRhoType   -- Actual -- a rho-type not a sigma-type-                  -> ExpRhoType  -- Expected-                  -> TcM TcCoercionN-unifyExpectedType rn_expr act_ty exp_ty-  = case exp_ty of-      Infer inf_res -> fillInferResult act_ty inf_res-      Check exp_ty  -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty---------------------------tcSubTypePat :: CtOrigin -> UserTypeCtxt-            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper--- Used in patterns; polarity is backwards compared---   to tcSubType--- If wrap = tc_sub_type_et t1 t2---    => wrap :: t1 ~> t2-tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected-  = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected--tcSubTypePat _ _ (Infer inf_res) ty_expected-  = do { co <- fillInferResult ty_expected inf_res-               -- In patterns we do not instantatiate--       ; return (mkWpCastN (mkSymCo co)) }------------------tcSubType :: CtOrigin -> UserTypeCtxt-          -> TcSigmaType  -- ^ Actual-          -> ExpRhoType   -- ^ Expected-          -> TcM HsWrapper--- Checks that 'actual' is more polymorphic than 'expected'-tcSubType orig ctxt ty_actual ty_expected-  = addSubTypeCtxt ty_actual ty_expected $-    do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])-       ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected }------------------tcSubTypeDS :: HsExpr GhcRn-            -> TcRhoType   -- Actual type -- a rho-type not a sigma-type-            -> TcRhoType   -- Expected type-                           -- DeepSubsumption <=> when checking, this type-                           --                     is deeply skolemised-            -> TcM HsWrapper--- Similar signature to unifyExpectedType; does deep subsumption--- Only one call site, in GHC.Tc.Gen.App.tcApp-tcSubTypeDS rn_expr act_rho exp_rho-  = tc_sub_type_deep (unifyExprType rn_expr) orig GenSigCtxt act_rho exp_rho-  where-    orig = exprCtOrigin rn_expr------------------tcSubTypeNC :: CtOrigin          -- ^ Used when instantiating-            -> UserTypeCtxt      -- ^ Used when skolemising-            -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known)-            -> TcSigmaType       -- ^ Actual type-            -> ExpRhoType        -- ^ Expected type-            -> TcM HsWrapper-tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty-  = case res_ty of-      Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt-                                       ty_actual ty_expected--      Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual-                                   -- See Note [Instantiation of InferResult]-                          ; co <- fillInferResult rho inf_res-                          ; return (mkWpCastN co <.> wrap) }------------------tcSubTypeSigma :: CtOrigin       -- where did the actual type arise / why are we-                                 -- doing this subtype check?-               -> UserTypeCtxt   -- where did the expected type arise?-               -> TcSigmaType -> TcSigmaType -> TcM HsWrapper--- External entry point, but no ExpTypes on either side--- Checks that actual <= expected--- Returns HsWrapper :: actual ~ expected-tcSubTypeSigma orig ctxt ty_actual ty_expected-  = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected------------------tcSubTypeAmbiguity :: UserTypeCtxt   -- Where did this type arise-                   -> TcSigmaType -> TcSigmaType -> TcM HsWrapper--- See Note [Ambiguity check and deep subsumption]-tcSubTypeAmbiguity ctxt ty_actual ty_expected-  = tc_sub_type_ds Shallow (unifyType Nothing)-                           (AmbiguityCheckOrigin ctxt)-                           ctxt ty_actual ty_expected------------------addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a-addSubTypeCtxt ty_actual ty_expected thing_inside- | isRhoTy ty_actual        -- If there is no polymorphism involved, the- , isRhoExpTy ty_expected   -- TypeEqOrigin stuff (added by the _NC functions)- = thing_inside             -- gives enough context by itself- | otherwise- = addErrCtxtM mk_msg thing_inside-  where-    mk_msg tidy_env-      = do { (tidy_env, ty_actual)   <- zonkTidyTcType tidy_env ty_actual-           ; ty_expected             <- readExpType ty_expected-                   -- A worry: might not be filled if we're debugging. Ugh.-           ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected-           ; let msg = vcat [ hang (text "When checking that:")-                                 4 (ppr ty_actual)-                            , nest 2 (hang (text "is more polymorphic than:")-                                         2 (ppr ty_expected)) ]-           ; return (tidy_env, msg) }---{- Note [Instantiation of InferResult]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We now always instantiate before filling in InferResult, so that-the result is a TcRhoType: see #17173 for discussion.--For example:--1. Consider-    f x = (*)-   We want to instantiate the type of (*) before returning, else we-   will infer the type-     f :: forall {a}. a -> forall b. Num b => b -> b -> b-   This is surely confusing for users.--   And worse, the monomorphism restriction won't work properly. The MR is-   dealt with in simplifyInfer, and simplifyInfer has no way of-   instantiating. This could perhaps be worked around, but it may be-   hard to know even when instantiation should happen.--2. Another reason.  Consider-       f :: (?x :: Int) => a -> a-       g y = let ?x = 3::Int in f-   Here want to instantiate f's type so that the ?x::Int constraint-  gets discharged by the enclosing implicit-parameter binding.--3. Suppose one defines plus = (+). If we instantiate lazily, we will-   infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism-   restriction compels us to infer-      plus :: Integer -> Integer -> Integer-   (or similar monotype). Indeed, the only way to know whether to apply-   the monomorphism restriction at all is to instantiate--There is one place where we don't want to instantiate eagerly,-namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type-command. See Note [Implementing :type] in GHC.Tc.Module.--}------------------tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN)  -- How to unify-            -> CtOrigin       -- Used when instantiating-            -> UserTypeCtxt   -- Used when skolemising-            -> TcSigmaType    -- Actual; a sigma-type-            -> TcSigmaType    -- Expected; also a sigma-type-            -> TcM HsWrapper--- Checks that actual_ty is more polymorphic than expected_ty--- If wrap = tc_sub_type t1 t2---    => wrap :: t1 ~> t2------ The "how to unify argument" is always a call to `uType TypeLevel orig`,--- but with different ways of constructing the CtOrigin `orig` from--- the argument types and context.-------------------------tc_sub_type unify inst_orig ctxt ty_actual ty_expected-  = do { ds_flag <- getDeepSubsumptionFlag-       ; tc_sub_type_ds ds_flag unify inst_orig ctxt ty_actual ty_expected }-------------------------tc_sub_type_ds :: DeepSubsumptionFlag-               -> (TcType -> TcType -> TcM TcCoercionN)-               -> CtOrigin -> UserTypeCtxt -> TcSigmaType-               -> TcSigmaType -> TcM HsWrapper--- tc_sub_type_ds is the main subsumption worker function--- It takes an explicit DeepSubsumptionFlag-tc_sub_type_ds ds_flag unify inst_orig ctxt ty_actual ty_expected-  | definitely_poly ty_expected   -- See Note [Don't skolemise unnecessarily]-  , isRhoTyDS ds_flag ty_actual-  = do { traceTc "tc_sub_type (drop to equality)" $-         vcat [ text "ty_actual   =" <+> ppr ty_actual-              , text "ty_expected =" <+> ppr ty_expected ]-       ; mkWpCastN <$>-         unify ty_actual ty_expected }--  | otherwise   -- This is the general case-  = do { traceTc "tc_sub_type (general case)" $-         vcat [ text "ty_actual   =" <+> ppr ty_actual-              , text "ty_expected =" <+> ppr ty_expected ]--       ; (sk_wrap, inner_wrap)-            <- tcSkolemise ds_flag ctxt ty_expected $ \sk_rho ->-               case ds_flag of-                 Deep    -> tc_sub_type_deep unify inst_orig ctxt ty_actual sk_rho-                 Shallow -> tc_sub_type_shallow unify inst_orig ty_actual sk_rho--       ; return (sk_wrap <.> inner_wrap) }-------------------------tc_sub_type_shallow :: (TcType -> TcType -> TcM TcCoercionN)-                    -> CtOrigin-                    -> TcSigmaType-                    -> TcRhoType   -- Skolemised (shallow-ly)-                    -> TcM HsWrapper-tc_sub_type_shallow unify inst_orig ty_actual sk_rho-  = do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual-       ; cow           <- unify rho_a sk_rho-       ; return (mkWpCastN cow <.> wrap) }-------------------------definitely_poly :: TcType -> Bool--- A very conservative test:--- see Note [Don't skolemise unnecessarily]-definitely_poly ty-  | (tvs, theta, tau) <- tcSplitSigmaTy ty-  , (tv:_) <- tvs   -- At least one tyvar-  , null theta      -- No constraints; see (DP1)-  , tv `isInjectiveInType` tau-       -- The tyvar actually occurs (DP2),-       -- and occurs in an injective position (DP3).-  = True-  | otherwise-  = False--{- Note [Don't skolemise unnecessarily]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we are trying to solve-     ty_actual   <= ty_expected-    (Char->Char) <= (forall a. a->a)-We could skolemise the 'forall a', and then complain-that (Char ~ a) is insoluble; but that's a pretty obscure-error.  It's better to say that-    (Char->Char) ~ (forall a. a->a)-fails.--If we prematurely go to equality we'll reject a program we should-accept (e.g. #13752).  So the test (which is only to improve error-message) is very conservative:-- * ty_actual   is /definitely/ monomorphic: see `definitely_mono`-   This definitely_mono test comes in "shallow" and "deep" variants-- * ty_expected is /definitely/ polymorphic: see `definitely_poly`-   This definitely_poly test is more subtle than you might think.-   Here are three cases where expected_ty looks polymorphic, but-   isn't, and where it would be /wrong/ to switch to equality:--   (DP1)  (Char->Char) <= (forall a. (a~Char) => a -> a)--   (DP2)  (Char->Char) <= (forall a. Char -> Char)--   (DP3)  (Char->Char) <= (forall a. F [a] Char -> Char)-                          where type instance F [x] t = t---Note [Coercions returned from tcSubMult]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At the moment, we insist that all sub-multiplicity tests turn out-(once the typechecker has finished its work) to be equalities,-i.e. implementable by ReflCo.  Why?  Because our type system has-no way to express non-Refl sub-multiplicities.--How can we check that every call to `tcSubMult` returns `Refl`?-It might not be `Refl` *yet*.--[TODO: add counterexample #25130]--So we take a two-stage approach:-* Generate a coercion now, and hang it in the HsSyn syntax tree-* In the desugarer, after zonking, check that it is Refl.--We "hang it in the tree" in two different ways:-A) In a HsWrapper, in the WpMultCoercion alternative. The-   desugarer checks that WpMultCoercions are Refl, and then-   discards them.  See `GHC.HsToCore.Binds.dsHsWrapper`-B) In an extension field.  For example, in the extension-   field of `HsRecFields`.  See `check_omitted_fields_multiplicity`-   in `GHC.Tc.Gen.Pat.tcDataConPat`--The former mechanism (A) seemed convenient at the time, but has-turned out to add a lot of friction, so we plan to move towards-(B): see #25128--An alternative would be to have a kind of constraint which can-only produce trivial evidence. This would allow such checks to happen-in the constraint solver (#18756).-This would be similar to the existing setup for Concrete, see-  Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete-    (PHASE 1 in particular).---}--tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper-tcSubMult' :: CtOrigin -> Mult -> Mult -> TcM MultiplicityCheckCoercions-tcSubMult origin w_actual w_expected =-  do { mult_cos <- tcSubMult' origin w_actual w_expected-     ; return (foldMap WpMultCoercion mult_cos) }-tcSubMult' origin w_actual w_expected-  | Just (w1, w2) <- isMultMul w_actual =-  do { w1 <- tcSubMult' origin w1 w_expected-     ; w2 <- tcSubMult' origin w2 w_expected-     ; return (w1 ++ w2) }-  -- Currently, we consider p*q and sup p q to be equal.  Therefore, p*q <= r is-  -- equivalent to p <= r and q <= r.  For other cases, we approximate p <= q by p-  -- ~ q.  This is not complete, but it's sound. See also Note [Overapproximating-  -- multiplicities] in Multiplicity.-tcSubMult' origin w_actual w_expected =-  case submult w_actual w_expected of-    Submult -> return []-    Unknown -> tcEqMult' origin w_actual w_expected--tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper-tcEqMult' :: CtOrigin -> Mult -> Mult -> TcM MultiplicityCheckCoercions-tcEqMult origin w_actual w_expected =-  do { mult_cos <- tcEqMult' origin w_actual w_expected-     ; return (foldMap WpMultCoercion mult_cos) }-tcEqMult' origin w_actual w_expected = do-  {-  -- Note that here we do not call to `submult`, so we check-  -- for strict equality.-  ; coercion <- unifyTypeAndEmit TypeLevel origin w_actual w_expected-  ; return $ if isReflCo coercion then [] else [coercion] }---{- *********************************************************************-*                                                                      *-                    Deep subsumption-*                                                                      *-********************************************************************* -}--{- Note [Deep subsumption]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The DeepSubsumption extension, documented here--    https://github.com/ghc-proposals/ghc-proposals/pull/511.--makes a best-efforts attempt implement deep subsumption as it was-prior to the Simplify Subsumption proposal:--    https://github.com/ghc-proposals/ghc-proposals/pull/287--The effects are in these main places:--1. In the subsumption check, tcSubType, we must do deep skolemisation:-   see the call to tcSkolemise Deep in tc_sub_type_deep--2. In tcPolyExpr we must do deep skolemisation:-   see the call to tcSkolemise in tcSkolemiseExpType--3. for expression type signatures (e :: ty), and functions with type-   signatures (e.g. f :: ty; f = e), we must deeply skolemise the type;-   see the call to tcDeeplySkolemise in tcSkolemiseScoped.--4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result-   type. Without deep subsumption, unifyExpectedType would be sufficent.--In all these cases note that the deep skolemisation must be done /first/.-Consider (1)-     (forall a. Int -> a -> a)  <=  Int -> (forall b. b -> b)-We must skolemise the `forall b` before instantiating the `forall a`.-See also Note [Deep skolemisation].--Wrinkles:--(DS1) Note that we /always/ use shallow subsumption in the ambiguity check.-      See Note [Ambiguity check and deep subsumption].--(DS2) Deep subsumption requires deep instantiation too.-      See Note [The need for deep instantiation]--(DS3) The interaction between deep subsumption and required foralls-      (forall a -> ty) is a bit subtle.  See #24696 and-      Note [Deep subsumption and required foralls]--Note [Deep skolemisation]-~~~~~~~~~~~~~~~~~~~~~~~~~-deeplySkolemise decomposes and skolemises a type, returning a type-with all its arrows visible (ie not buried under foralls)--Examples:--  deeplySkolemise (Int -> forall a. Ord a => blah)-    =  ( wp, [a], [d:Ord a], Int -> blah )-    where wp = \x:Int. /\a. \(d:Ord a). <hole> x--  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)-    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )-    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x--In general,-  if      deeplySkolemise ty = (wrap, tvs, evs, rho)-    and   e :: rho-  then    wrap e :: ty-    and   'wrap' binds tvs, evs--ToDo: this eta-abstraction plays fast and loose with termination,-      because it can introduce extra lambdas.  Maybe add a `seq` to-      fix this--Note [Setting the argument context]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider we are doing the ambiguity check for the (bogus)-  f :: (forall a b. C b => a -> a) -> Int--We'll call-   tcSubType ((forall a b. C b => a->a) -> Int )-             ((forall a b. C b => a->a) -> Int )--with a UserTypeCtxt of (FunSigCtxt "f").  Then we'll do the co/contra thing-on the argument type of the (->) -- and at that point we want to switch-to a UserTypeCtxt of GenSigCtxt.  Why?--* Error messages.  If we stick with FunSigCtxt we get errors like-     * Could not deduce: C b-       from the context: C b0-        bound by the type signature for:-            f :: forall a b. C b => a->a-  But of course f does not have that type signature!-  Example tests: T10508, T7220a, Simple14--* Implications. We may decide to build an implication for the whole-  ambiguity check, but we don't need one for each level within it,-  and TcUnify.alwaysBuildImplication checks the UserTypeCtxt.-  See Note [When to build an implication]--Note [Multiplicity in deep subsumption]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   t1 ->{mt} t2  <=   s1 ->{ms} s2--At the moment we /unify/ ms~mt, via tcEqMult.--Arguably we should use `tcSubMult`. But then if mt=m0 (a unification-variable) and ms=Many, `tcSubMult` is a no-op (since anything is a-sub-multiplicty of Many).  But then `m0` may never get unified with-anything.  It is then skolemised by the zonker; see GHC.HsToCore.Binds-Note [Free tyvars on rule LHS].  So we in RULE foldr/app in GHC.Base-we get this-- "foldr/app"     [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys-                                       = \xs -> xs ++ ys--where we eta-expanded that (:).  But now foldr expects an argument-with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint-complains.--The easiest solution was to use tcEqMult in tc_sub_type_deep, and-insist on equality. This is only in the DeepSubsumption code anyway.--Note [The need for deep instantiation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this, without Quick Look, but with Deep Subsumption:-   f :: ∀a b c. a b c -> Int-   g :: Bool -> ∀d. d -> d-Consider the application (f g).  We need to do the subsumption test--  (Bool -> ∀ d. d->d)   <=   (alpha beta gamma)--where alpha, beta, gamma are the unification variables that instantiate a,b,c,-respectively.  We must not drop down to unification, or we will reject the call.-Rather we must deeply instantiate the LHS to get--  (Bool -> delta -> delta)   <=   (alpha beta gamma)--and now we can unify to get--   alpha = (->)-   beta = Bool-   gamma = delta -> delta--Hence the call to `deeplyInstantiate` in `tc_sub_type_deep`.--See typecheck/should_compile/T11305 for an example of when this is important.--Note [Deep subsumption and required foralls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A required forall, (forall a -> ty) behaves like a "rho-type", one with no-top-level quantification.  In particular, it is neither implicitly instantiated nor-skolemised.  So--  rid1 :: forall a -> a -> a-  rid1 = id--  rid2 :: forall a -> a -> a-  rid2 a = id--Here `rid2` wll typecheck, but `rid1` will not, because we don't implicitly skolemise-the  type.--This "no implicit subsumption nor skolemisation" applies during subsumption.-For example-   (forall a. a->a)  <=  (forall a -> a -> a)  -- NOT!-does /not/ hold, because that would require implicitly skoleming the (forall a->).--Note also that, in Core, `eqType` distinguishes between-   (forall a. blah) and forall a -> blah)-See discussion on #22762 and these Notes in GHC.Core.TyCo.Compare-  * Note [ForAllTy and type equality]-  * Note [Comparing visibility]--So during deep subsumption we simply stop (and drop down to equality) when we encounter-a (forall a->).  This is a little odd:-* Deep subsumption looks inside invisible foralls (forall a. ty)-* Deep subsumption looks inside arrows (t1 -> t2)-* But it does not look inside required foralls (forall a -> ty)--There is discussion on #24696.  How is this implemented?--* In `tc_sub_type_deep`, the calls to `topInstantiate` and `deeplyInstantiate`-  instantiate only /invisible/ binders.-* In `tc_sub_type_ds`, the call to `tcSkolemise` skolemises only /invisible/-  binders.--Here is a slightly more powerful alternative-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- In the story above, if we have-    (forall a -> Eq a => a -> a)  <=  (forall a -> Ord a => a -> a)-we'll reject it, because both are rho-types but they aren't equal.  But in the-"drop to equality" stage we could instead see if both rho-types are headed with-(forall a ->) and if so strip that off and go back into deep subsumption.--This is a bit more powerful, but also a bit more complicated, so GHC-doesn't do it yet, awaiting credible user demand.  See #24696.--}--data DeepSubsumptionFlag = Deep | Shallow--instance Outputable DeepSubsumptionFlag where-    ppr Deep    = text "Deep"-    ppr Shallow = text "Shallow"--getDeepSubsumptionFlag :: TcM DeepSubsumptionFlag-getDeepSubsumptionFlag = do { ds <- xoptM LangExt.DeepSubsumption-                            ; if ds then return Deep else return Shallow }--tc_sub_type_deep :: HasDebugCallStack-                 => (TcType -> TcType -> TcM TcCoercionN)  -- How to unify-                 -> CtOrigin       -- Used when instantiating-                 -> UserTypeCtxt   -- Used when skolemising-                 -> TcSigmaType    -- Actual; a sigma-type-                 -> TcRhoType      -- Expected; deeply skolemised-                 -> TcM HsWrapper---- If wrap = tc_sub_type_deep t1 t2---    => wrap :: t1 ~> t2--- Here is where the work actually happens!--- Precondition: ty_expected is deeply skolemised--tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected-  = assertPpr (isDeepRhoTy ty_expected) (ppr ty_expected) $-    do { traceTc "tc_sub_type_deep" $-         vcat [ text "ty_actual   =" <+> ppr ty_actual-              , text "ty_expected =" <+> ppr ty_expected ]-       ; go ty_actual ty_expected }-  where-    -- NB: 'go' is not recursive, except for doing coreView-    go ty_a ty_e | Just ty_a' <- coreView ty_a = go ty_a' ty_e-                 | Just ty_e' <- coreView ty_e = go ty_a  ty_e'--    go (TyVarTy tv_a) ty_e-      = do { lookup_res <- isFilledMetaTyVar_maybe tv_a-           ; case lookup_res of-               Just ty_a' ->-                 do { traceTc "tc_sub_type_deep following filled meta-tyvar:"-                        (ppr tv_a <+> text "-->" <+> ppr ty_a')-                    ; tc_sub_type_deep unify inst_orig ctxt ty_a' ty_e }-               Nothing -> just_unify ty_actual ty_expected }--    go ty_a@(FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res })-       ty_e@(FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res })-      | isVisibleFunArg af1, isVisibleFunArg af2-      = if (isTauTy ty_a && isTauTy ty_e)       -- Short cut common case to avoid-        then just_unify ty_actual ty_expected   -- unnecessary eta expansion-        else-        -- This is where we do the co/contra thing, and generate a WpFun, which in turn-        -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption-        do { arg_wrap  <- tc_sub_type_ds Deep unify given_orig GenSigCtxt exp_arg act_arg-                          -- GenSigCtxt: See Note [Setting the argument context]-           ; res_wrap  <- tc_sub_type_deep unify inst_orig ctxt act_res exp_res-           ; mult_wrap <- tcEqMult inst_orig act_mult exp_mult-                          -- See Note [Multiplicity in deep subsumption]-           ; return (mult_wrap <.>-                     mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res) }-                     -- arg_wrap :: exp_arg ~> act_arg-                     -- res_wrap :: act-res ~> exp_res-      where-        given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])--    go ty_a ty_e-      | let (tvs, theta, _) = tcSplitSigmaTy ty_a-      , not (null tvs && null theta)-      = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a-           ; body_wrap <- tc_sub_type_deep unify inst_orig ctxt in_rho ty_e-           ; return (body_wrap <.> in_wrap) }--      | otherwise   -- Revert to unification-      = do { -- It's still possible that ty_actual has nested foralls. Instantiate-             -- these, as there's no way unification will succeed with them in.-             -- See Note [The need for deep instantiation]-             (inst_wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual-           ; unify_wrap         <- just_unify rho_a ty_expected-           ; return (unify_wrap <.> inst_wrap) }--    just_unify ty_a ty_e = do { cow <- unify ty_a ty_e-                              ; return (mkWpCastN cow) }--------------------------deeplySkolemise :: SkolemInfo -> TcSigmaType-                -> TcM ( HsWrapper-                       , [(Name,TcInvisTVBinder)]     -- All skolemised variables-                       , [EvVar]                      -- All "given"s-                       , TcRhoType )--- See Note [Deep skolemisation]-deeplySkolemise skol_info ty-  = go init_subst ty-  where-    init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))--    go subst ty-      | Just (arg_tys, bndrs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty-      = do { let arg_tys' = substScaledTys subst arg_tys-           ; ids1             <- newSysLocalIds (fsLit "dk") arg_tys'-           ; (subst', bndrs1) <- tcInstSkolTyVarBndrsX skol_info subst bndrs-           ; ev_vars1         <- newEvVars (substTheta subst' theta)-           ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'-           ; let tvs     = binderVars bndrs-                 tvs1    = binderVars bndrs1-                 tv_prs1 = map tyVarName tvs `zip` bndrs1-           ; return ( mkWpEta ids1 (mkWpTyLams tvs1-                                    <.> mkWpEvLams ev_vars1-                                    <.> wrap)-                    , tv_prs1  ++ tvs_prs2-                    , ev_vars1 ++ ev_vars2-                    , mkScaledFunTys arg_tys' rho ) }--      | otherwise-      = return (idHsWrapper, [], [], substTy subst ty)-        -- substTy is a quick no-op on an empty substitution--deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)-deeplyInstantiate orig ty-  = go init_subst ty-  where-    init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))--    go subst ty-      | Just (arg_tys, bndrs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty-      = do { let tvs = binderVars bndrs-           ; (subst', tvs') <- newMetaTyVarsX subst tvs-           ; let arg_tys' = substScaledTys   subst' arg_tys-                 theta'   = substTheta subst' theta-           ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'-           ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'-           ; (wrap2, rho2) <- go subst' rho-           ; return (mkWpEta ids1 (wrap2 <.> wrap1),-                     mkScaledFunTys arg_tys' rho2) }--      | otherwise-      = do { let ty' = substTy subst ty-           ; return (idHsWrapper, ty') }--tcDeepSplitSigmaTy_maybe-  :: TcSigmaType -> Maybe ([Scaled TcType], [TcInvisTVBinder], ThetaType, TcSigmaType)--- Looks for a *non-trivial* quantified type, under zero or more function arrows--- By "non-trivial" we mean either tyvars or constraints are non-empty-tcDeepSplitSigmaTy_maybe ty-  = go ty-  where-  go ty | Just (arg_ty, res_ty)           <- tcSplitFunTy_maybe ty-        , Just (arg_tys, tvs, theta, rho) <- go res_ty-        = Just (arg_ty:arg_tys, tvs, theta, rho)--        | (tvs, theta, rho) <- tcSplitSigmaTyBndrs ty-        , not (null tvs && null theta)-        = Just ([], tvs, theta, rho)--        | otherwise = Nothing--isDeepRhoTy :: TcType -> Bool--- True if there are no foralls or (=>) at the top, or nested under--- arrows to the right.  e.g---    forall a. a                  False---    Int -> forall a. a           False---    (forall a. a) -> Int         True--- Returns True iff tcDeepSplitSigmaTy_maybe returns Nothing-isDeepRhoTy ty-  | not (isRhoTy ty)                       = False  -- Foralls or (=>) at top-  | Just (_, res) <- tcSplitFunTy_maybe ty = isDeepRhoTy res-  | otherwise                              = True   -- No forall, (=>), or (->) at top--isRhoTyDS :: DeepSubsumptionFlag -> TcType -> Bool-isRhoTyDS ds_flag ty-  = case ds_flag of-      Shallow -> isRhoTy ty      -- isRhoTy: no top level forall or (=>)-      Deep    -> isDeepRhoTy ty  -- "deep" version: no nested forall or (=>)--{--************************************************************************-*                                                                      *-                Boxy unification-*                                                                      *-************************************************************************--The exported functions are all defined as versions of some-non-exported generic functions.--}--unifyExprType :: HsExpr GhcRn -> TcType -> TcType -> TcM TcCoercionN-unifyExprType rn_expr ty1 ty2-  = unifyType (Just (HsExprRnThing rn_expr)) ty1 ty2--unifyType :: Maybe TypedThing  -- ^ If present, the thing that has type ty1-          -> TcTauType -> TcTauType    -- ty1 (actual), ty2 (expected)-          -> TcM TcCoercionN           -- :: ty1 ~# ty2--- Actual and expected types--- Returns a coercion : ty1 ~ ty2-unifyType thing ty1 ty2-  = unifyTypeAndEmit TypeLevel origin ty1 ty2-  where-    origin = TypeEqOrigin { uo_actual   = ty1-                          , uo_expected = ty2-                          , uo_thing    = thing-                          , uo_visible  = True }--unifyInvisibleType :: TcTauType -> TcTauType    -- ty1 (actual), ty2 (expected)-                   -> TcM TcCoercionN           -- :: ty1 ~# ty2--- Actual and expected types--- Returns a coercion : ty1 ~ ty2-unifyInvisibleType ty1 ty2-  = unifyTypeAndEmit TypeLevel origin ty1 ty2-  where-    origin = TypeEqOrigin { uo_actual   = ty1-                          , uo_expected = ty2-                          , uo_thing    = Nothing-                          , uo_visible  = False }  -- This is the "invisible" bit--unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN--- Like unifyType, but swap expected and actual in error messages--- This is used when typechecking patterns-unifyTypeET ty1 ty2-  = unifyTypeAndEmit TypeLevel origin ty1 ty2-  where-    origin = TypeEqOrigin { uo_actual   = ty2   -- NB swapped-                          , uo_expected = ty1   -- NB swapped-                          , uo_thing    = Nothing-                          , uo_visible  = True }---unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN-unifyKind mb_thing ty1 ty2-  = unifyTypeAndEmit KindLevel origin ty1 ty2-  where-    origin = TypeEqOrigin { uo_actual   = ty1-                          , uo_expected = ty2-                          , uo_thing    = mb_thing-                          , uo_visible  = True }--unifyTypeAndEmit :: TypeOrKind -> CtOrigin -> TcType -> TcType -> TcM CoercionN--- Make a ref-cell, unify, emit the collected constraints-unifyTypeAndEmit t_or_k orig ty1 ty2-  = do { ref <- newTcRef emptyBag-       ; loc <- getCtLocM orig (Just t_or_k)-       ; let env = UE { u_loc = loc, u_role = Nominal-                      , u_rewriters = emptyRewriterSet  -- ToDo: check this-                      , u_defer = ref, u_unified = Nothing }--       -- The hard work happens here-       ; co <- uType env ty1 ty2--       ; cts <- readTcRef ref-       ; unless (null cts) (emitSimples cts)-       ; return co }--{--%************************************************************************-%*                                                                      *-                 uType and friends-%*                                                                      *-%************************************************************************--Note [The eager unifier]-~~~~~~~~~~~~~~~~~~~~~~~~-The eager unifier, `uType`, is called by--  * The constraint generator (e.g. in GHC.Tc.Gen.Expr),-    via the wrappers `unifyType`, `unifyKind` etc--  * The constraint solver (e.g. in GHC.Tc.Solver.Equality),-    via `GHC.Tc.Solver.Monad.wrapUnifierTcS`.--`uType` runs in the TcM monad, but it carries a UnifyEnv that tells it-what to do when unifying a variable or deferring a constraint. Specifically,-  * it collects deferred constraints in `u_defer`, and-  * it records which unification variables it has unified in `u_unified`-Then it is up to the wrappers (one for the constraint generator, one for-the constraint solver) to deal with these collected sets.--Although `uType` runs in the TcM monad for convenience, really it could-operate just with the ability to-  * write to the accumulators of deferred constraints-    and unification variables in UnifyEnv.-  * read and update existing unification variables-  * zonk types befire unifying (`zonkTcType` in `uUnfilledVar`, and-    `zonkTyCoVarKind` in `uUnfilledVar1`-  * create fresh coercion holes (`newCoercionHole`)-  * emit tracing info for debugging-  * look at the ambient TcLevel: `getTcLevel`-A job for the future.--}--data UnifyEnv-  = UE { u_role      :: Role-       , u_loc       :: CtLoc-       , u_rewriters :: RewriterSet--         -- Deferred constraints-       , u_defer     :: TcRef (Bag Ct)--         -- Which variables are unified;-         -- if Nothing, we don't care-       , u_unified :: Maybe (TcRef [TcTyVar])-    }--setUEnvRole :: UnifyEnv -> Role -> UnifyEnv-setUEnvRole uenv role = uenv { u_role = role }--updUEnvLoc :: UnifyEnv -> (CtLoc -> CtLoc) -> UnifyEnv-updUEnvLoc uenv@(UE { u_loc = loc }) upd = uenv { u_loc = upd loc }--mkKindEnv :: UnifyEnv -> TcType -> TcType -> UnifyEnv--- Modify the UnifyEnv to be right for unifing--- the kinds of these two types-mkKindEnv env@(UE { u_loc = ctloc }) ty1 ty2-  = env { u_role = Nominal, u_loc = mkKindEqLoc ty1 ty2 ctloc }--uType, uType_defer-  :: UnifyEnv-  -> TcType    -- ty1 is the *actual* type-  -> TcType    -- ty2 is the *expected* type-  -> TcM CoercionN---- It is always safe to defer unification to the main constraint solver--- See Note [Deferred unification]-uType_defer (UE { u_loc = loc, u_defer = ref-                , u_role = role, u_rewriters = rewriters })-            ty1 ty2  -- ty1 is "actual", ty2 is "expected"-  = do { let pred_ty = mkPrimEqPredRole role ty1 ty2-       ; hole <- newCoercionHole loc pred_ty-       ; let ct = mkNonCanonical $-                  CtWanted { ctev_pred      = pred_ty-                           , ctev_dest      = HoleDest hole-                           , ctev_loc       = loc-                           , ctev_rewriters = rewriters }-             co = HoleCo hole-       ; updTcRef ref (`snocBag` ct)-         -- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality--       -- Error trace only-       -- NB. do *not* call mkErrInfo unless tracing is on,-       --     because it is hugely expensive (#5631)-       ; whenDOptM Opt_D_dump_tc_trace $-         do { ctxt <- getErrCtxt-            ; doc  <- mkErrInfo emptyTidyEnv ctxt-            ; traceTc "utype_defer" (vcat [ ppr role-                                          , debugPprType ty1-                                          , debugPprType ty2-                                          , doc])-            ; traceTc "utype_defer2" (ppr co) }--       ; return co }------------------uType env@(UE { u_role = role }) orig_ty1 orig_ty2-  | Phantom <- role-  = do { kind_co <- uType (mkKindEnv env orig_ty1 orig_ty2)-                          (typeKind orig_ty1) (typeKind orig_ty2)-       ; return (mkPhantomCo kind_co orig_ty1 orig_ty2) }--  | otherwise-  = do { tclvl <- getTcLevel-       ; traceTc "u_tys" $ vcat-              [ text "tclvl" <+> ppr tclvl-              , sep [ ppr orig_ty1, text "~" <> ppr role, ppr orig_ty2] ]-       ; co <- go orig_ty1 orig_ty2-       ; if isReflCo co-            then traceTc "u_tys yields no coercion" Outputable.empty-            else traceTc "u_tys yields coercion:" (ppr co)-       ; return co }-  where-    go :: TcType -> TcType -> TcM CoercionN-        -- The arguments to 'go' are always semantically identical-        -- to orig_ty{1,2} except for looking through type synonyms--     -- Unwrap casts before looking for variables. This way, we can easily-     -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we-     -- didn't do it this way, and then the unification above was deferred.-    go (CastTy t1 co1) t2-      = do { co_tys <- uType env t1 t2-           ; return (mkCoherenceLeftCo role t1 co1 co_tys) }--    go t1 (CastTy t2 co2)-      = do { co_tys <- uType env t1 t2-           ; return (mkCoherenceRightCo role t2 co2 co_tys) }--        -- Variables; go for uUnfilledVar-        -- Note that we pass in *original* (before synonym expansion),-        -- so that type variables tend to get filled in with-        -- the most informative version of the type-    go (TyVarTy tv1) ty2-      = do { lookup_res <- isFilledMetaTyVar_maybe tv1-           ; case lookup_res of-               Just ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)-                              ; uType env ty1 orig_ty2 }-               Nothing -> uUnfilledVar env NotSwapped tv1 ty2 }--    go ty1 (TyVarTy tv2)-      = do { lookup_res <- isFilledMetaTyVar_maybe tv2-           ; case lookup_res of-               Just ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)-                              ; uType env orig_ty1 ty2 }-               Nothing -> uUnfilledVar env IsSwapped tv2 ty1 }--      -- See Note [Unifying type synonyms] in GHC.Core.Unify-    go ty1@(TyConApp tc1 []) (TyConApp tc2 [])-      | tc1 == tc2-      = return $ mkReflCo role ty1--        -- Now expand synonyms-        -- See Note [Expanding synonyms during unification]-        ---        -- Also NB that we recurse to 'go' so that we don't push a-        -- new item on the origin stack. As a result if we have-        --   type Foo = Int-        -- and we try to unify  Foo ~ Bool-        -- we'll end up saying "can't match Foo with Bool"-        -- rather than "can't match "Int with Bool".  See #4535.-    go ty1 ty2-      | Just ty1' <- coreView ty1 = go ty1' ty2-      | Just ty2' <- coreView ty2 = go ty1  ty2'--    -- Functions (t1 -> t2) just check the two parts-    go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 })-       (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 })-      | isVisibleFunArg af1  -- Do not attempt (c => t); just defer-      , af1 == af2           -- Important!  See #21530-      = do { co_w <- uType (env { u_role = funRole role SelMult }) w1   w2-           ; co_l <- uType (env { u_role = funRole role SelArg })  arg1 arg2-           ; co_r <- uType (env { u_role = funRole role SelRes })  res1 res2-           ; return $ mkNakedFunCo role af1 co_w co_l co_r }--        -- Always defer if a type synonym family (type function)-        -- is involved.  (Data families behave rigidly.)-    go ty1@(TyConApp tc1 _) ty2-      | isTypeFamilyTyCon tc1 = defer ty1 ty2-    go ty1 ty2@(TyConApp tc2 _)-      | isTypeFamilyTyCon tc2 = defer ty1 ty2--    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      -- See Note [Mismatched type lists and application decomposition]-      | tc1 == tc2, equalLength tys1 tys2-      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality-      = assertPpr (isGenerativeTyCon tc1 role) (ppr tc1) $-        do { traceTc "go-tycon" (ppr tc1 $$ ppr tys1 $$ ppr tys2 $$ ppr (take 10 (tyConRoleListX role tc1)))-           ; cos <- zipWith4M u_tc_arg (tyConVisibilities tc1)   -- Infinite-                                       (tyConRoleListX role tc1) -- Infinite-                                       tys1 tys2-           ; return $ mkTyConAppCo role tc1 cos }--    go (LitTy m) ty@(LitTy n)-      | m == n-      = return $ mkReflCo role ty--        -- See Note [Care with type applications]-        -- Do not decompose FunTy against App;-        -- it's often a type error, so leave it for the constraint solver-    go ty1@(AppTy s1 t1) ty2@(AppTy s2 t2)-      = go_app (isNextArgVisible s1) ty1 s1 t1 ty2 s2 t2--    go ty1@(AppTy s1 t1) ty2@(TyConApp tc2 ts2)-      | Just (ts2', t2') <- snocView ts2-      = assert (not (tyConMustBeSaturated tc2)) $-        go_app (isNextTyConArgVisible tc2 ts2')-               ty1 s1 t1 ty2 (TyConApp tc2 ts2') t2'--    go ty1@(TyConApp tc1 ts1) ty2@(AppTy s2 t2)-      | Just (ts1', t1') <- snocView ts1-      = assert (not (tyConMustBeSaturated tc1)) $-        go_app (isNextTyConArgVisible tc1 ts1')-               ty1 (TyConApp tc1 ts1') t1' ty2 s2 t2--    go ty1@(CoercionTy co1) ty2@(CoercionTy co2)-      = do { kco <- uType (mkKindEnv env ty1 ty2)-                          (coercionType co1) (coercionType co2)-           ; return $ mkProofIrrelCo role kco co1 co2 }--        -- Anything else fails-        -- E.g. unifying for-all types, which is relative unusual-    go ty1 ty2 = defer ty1 ty2--    -------------------    defer ty1 ty2   -- See Note [Check for equality before deferring]-      | ty1 `tcEqType` ty2 = return (mkReflCo role ty1)-      | otherwise          = uType_defer env orig_ty1 orig_ty2---    -------------------    u_tc_arg is_vis role ty1 ty2-      = do { traceTc "u_tc_arg" (ppr role $$ ppr ty1 $$ ppr ty2)-           ; uType env_arg ty1 ty2 }-      where-        env_arg = env { u_loc = adjustCtLoc is_vis False (u_loc env)-                      , u_role = role }--    -------------------    -- For AppTy, decompose only nominal equalities-    -- See Note [Decomposing AppTy equalities] in GHC.Tc.Solver.Equality-    go_app vis ty1 s1 t1 ty2 s2 t2-      | Nominal <- role-      = -- Unify arguments t1/t2 before function s1/s2, because-        -- the former have smaller kinds, and hence simpler error messages-        -- c.f. GHC.Tc.Solver.Equality.can_eq_app-        -- Example: test T8603-        do { let env_arg = env { u_loc = adjustCtLoc vis False (u_loc env) }-           ; co_t <- uType env_arg t1 t2-           ; co_s <- uType env s1 s2-           ; return $ mkAppCo co_s co_t }-      | otherwise-      = defer ty1 ty2--{- Note [Check for equality before deferring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Particularly in ambiguity checks we can get equalities like (ty ~ ty).-If ty involves a type function we may defer, which isn't very sensible.-An egregious example of this was in test T9872a, which has a type signature-       Proxy :: Proxy (Solutions Cubes)-Doing the ambiguity check on this signature generates the equality-   Solutions Cubes ~ Solutions Cubes-and currently the constraint solver normalises both sides at vast cost.-This little short-cut in 'defer' helps quite a bit.--Note [Care with type applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Note: type applications need a bit of care!-They can match FunTy and TyConApp, so use splitAppTy_maybe-NB: we've already dealt with type variables and Notes,-so if one type is an App the other one jolly well better be too--Note [Mismatched type lists and application decomposition]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we find two TyConApps, you might think that the argument lists-are guaranteed equal length.  But they aren't. Consider matching-        w (T x) ~ Foo (T x y)-We do match (w ~ Foo) first, but in some circumstances we simply create-a deferred constraint; and then go ahead and match (T x ~ T x y).-This came up in #3950.--So either-   (a) either we must check for identical argument kinds-       when decomposing applications,--   (b) or we must be prepared for ill-kinded unification sub-problems--Currently we adopt (b) since it seems more robust -- no need to maintain-a global invariant.--Note [Expanding synonyms during unification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We expand synonyms during unification, but:- * We expand *after* the variable case so that we tend to unify-   variables with un-expanded type synonym. This just makes it-   more likely that the inferred types will mention type synonyms-   understandable to the user-- * Similarly, we expand *after* the CastTy case, just in case the-   CastTy wraps a variable.-- * We expand *before* the TyConApp case.  For example, if we have-      type Phantom a = Int-   and are unifying-      Phantom Int ~ Phantom Char-   it is *wrong* to unify Int and Char.-- * The problem case immediately above can happen only with arguments-   to the tycon. So we check for nullary tycons *before* expanding.-   This is particularly helpful when checking (* ~ *), because * is-   now a type synonym.  See Note [Unifying type synonyms] in GHC.Core.Unify.--Note [Deferred unification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,-and yet its consistency is undetermined. Previously, there was no way to still-make it consistent. So a mismatch error was issued.--Now these unifications are deferred until constraint simplification, where type-family instances and given equations may (or may not) establish the consistency.-Deferred unifications are of the form-                F ... ~ ...-or              x ~ ...-where F is a type function and x is a type variable.-E.g.-        id :: x ~ y => x -> y-        id e = e--involves the unification x = y. It is deferred until we bring into account the-context x ~ y to establish that it holds.--If available, we defer original types (rather than those where closed type-synonyms have already been expanded via tcCoreView).  This is, as usual, to-improve error messages.--************************************************************************-*                                                                      *-                 uUnfilledVar and friends-*                                                                      *-************************************************************************--@uunfilledVar@ is called when at least one of the types being unified is a-variable.  It does {\em not} assume that the variable is a fixed point-of the substitution; rather, notice that @uVar@ (defined below) nips-back into @uTys@ if it turns out that the variable is already bound.--}-------------uUnfilledVar, uUnfilledVar1-    :: UnifyEnv-    -> SwapFlag-    -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar-                      --    definitely not a /filled/ meta-tyvar-    -> TcTauType      -- Type 2-    -> TcM CoercionN--- "Unfilled" means that the variable is definitely not a filled-in meta tyvar---            It might be a skolem, or untouchable, or meta-uUnfilledVar env swapped tv1 ty2-  | Nominal <- u_role env-  = do { ty2 <- liftZonkM $ zonkTcType ty2-                  -- Zonk to expose things to the occurs check, and so-                  -- that if ty2 looks like a type variable then it-                  -- /is/ a type variable-       ; uUnfilledVar1 env swapped tv1 ty2 }--  | otherwise  -- See Note [Do not unify representational equalities]-               -- in GHC.Tc.Solver.Equality-  = unSwap swapped (uType_defer env) (mkTyVarTy tv1) ty2--uUnfilledVar1 env       -- Precondition: u_role==Nominal-              swapped-              tv1-              ty2       -- ty2 is zonked-  | Just tv2 <- getTyVar_maybe ty2-  = go tv2--  | otherwise-  = uUnfilledVar2 env swapped tv1 ty2--  where-    -- 'go' handles the case where both are-    -- tyvars so we might want to swap-    -- E.g. maybe tv2 is a meta-tyvar and tv1 is not-    go tv2 | tv1 == tv2  -- Same type variable => no-op-           = return (mkNomReflCo (mkTyVarTy tv1))--           | swapOverTyVars False tv1 tv2   -- Distinct type variables-               -- Swap meta tyvar to the left if poss-           = do { tv1 <- liftZonkM $ zonkTyCoVarKind tv1-                     -- We must zonk tv1's kind because that might-                     -- not have happened yet, and it's an invariant of-                     -- uUnfilledTyVar2 that ty2 is fully zonked-                     -- Omitting this caused #16902-                ; uUnfilledVar2 env (flipSwap swapped) tv2 (mkTyVarTy tv1) }--           | otherwise-           = uUnfilledVar2 env swapped tv1 ty2-------------uUnfilledVar2 :: UnifyEnv       -- Precondition: u_role==Nominal-              -> SwapFlag-              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar-                                --    definitely not a /filled/ meta-tyvar-              -> TcTauType      -- Type 2, zonked-              -> TcM CoercionN-uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2-  = do { cur_lvl <- getTcLevel-           -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles-           -- Here we don't know about given equalities here; so we treat-           -- /any/ level outside this one as untouchable.  Hence cur_lvl.-       ; if not (touchabilityAndShapeTest cur_lvl tv1 ty2-                 && simpleUnifyCheck UC_OnTheFly tv1 ty2)-         then not_ok_so_defer cur_lvl-         else-    do { def_eqs <- readTcRef def_eq_ref  -- Capture current state of def_eqs--       -- Attempt to unify kinds-       -- When doing so, be careful to preserve orientation;-       --    see Note [Kind Equality Orientation] in GHC.Tc.Solver.Equality-       --    and wrinkle (W2) in Note [Fundeps with instances, and equality orientation]-       --        in GHC.Tc.Solver.Dict-       -- Failing to preserve orientation led to #25597.-       ; let kind_env = unSwap swapped (mkKindEnv env) ty1 ty2-       ; co_k <- unSwap swapped (uType kind_env) (tyVarKind tv1) (typeKind ty2)--       ; traceTc "uUnfilledVar2 ok" $-         vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)-              , ppr ty2 <+> dcolon <+> ppr (typeKind  ty2)-              , ppr (isReflCo co_k), ppr co_k ]--       ; if isReflCo co_k-           -- Only proceed if the kinds match-           -- NB: tv1 should still be unfilled, despite the kind unification-           --     because tv1 is not free in ty2' (or, hence, in its kind)-         then do { liftZonkM $ writeMetaTyVar tv1 ty2-                 ; case u_unified env of-                     Nothing -> return ()-                     Just uref -> updTcRef uref (tv1 :)-                 ; return (mkNomReflCo ty2) }  -- Unification is always Nominal--         else -- The kinds don't match yet, so defer instead.-              do { writeTcRef def_eq_ref def_eqs-                     -- Since we are discarding co_k, also discard any constraints-                     -- emitted by kind unification; they are just useless clutter.-                     -- Do this dicarding by simply restoring the previous state-                     -- of def_eqs; a bit imperative/yukky but works fine.-                 ; defer }-         }}-  where-    ty1 = mkTyVarTy tv1-    defer = unSwap swapped (uType_defer env) ty1 ty2--    not_ok_so_defer cur_lvl =-      do { traceTc "uUnfilledVar2 not ok" $-             vcat [ text "tv1:" <+> ppr tv1-                  , text "ty2:" <+> ppr ty2-                  , text "simple-unify-chk:" <+> ppr (simpleUnifyCheck UC_OnTheFly tv1 ty2)-                  , text "touchability:" <+> ppr (touchabilityAndShapeTest cur_lvl tv1 ty2)]-               -- Occurs check or an untouchable: just defer-               -- NB: occurs check isn't necessarily fatal:-               --     eg tv1 occurred in type family parameter-          ; defer }--swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool-swapOverTyVars is_given tv1 tv2-  -- See Note [Unification variables on the left]-  | not is_given, pri1 == 0, pri2 > 0 = True-  | not is_given, pri2 == 0, pri1 > 0 = False--  -- Level comparison: see Note [TyVar/TyVar orientation]-  | lvl1 `strictlyDeeperThan` lvl2 = False-  | lvl2 `strictlyDeeperThan` lvl1 = True--  -- Priority: see Note [TyVar/TyVar orientation]-  | pri1 > pri2 = False-  | pri2 > pri1 = True--  -- Names: see Note [TyVar/TyVar orientation]-  | isSystemName tv2_name, not (isSystemName tv1_name) = True--  | otherwise = False--  where-    lvl1 = tcTyVarLevel tv1-    lvl2 = tcTyVarLevel tv2-    pri1 = lhsPriority tv1-    pri2 = lhsPriority tv2-    tv1_name = Var.varName tv1-    tv2_name = Var.varName tv2---lhsPriority :: TcTyVar -> Int--- Higher => more important to be on the LHS---        => more likely to be eliminated--- Only used when the levels are identical--- See Note [TyVar/TyVar orientation]-lhsPriority tv-  = assertPpr (isTyVar tv) (ppr tv) $-    case tcTyVarDetails tv of-      RuntimeUnk  -> 0-      SkolemTv {} -> 0-      MetaTv { mtv_info = info, mtv_tclvl = lvl }-        | QLInstVar <- lvl-        -> 5  -- Eliminate instantiation variables first-        | otherwise-        -> case info of-             CycleBreakerTv -> 0-             TyVarTv        -> 1-             ConcreteTv {}  -> 2-             TauTv          -> 3-             RuntimeUnkTv   -> 4--{- Note [Unification preconditions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Question: given a homogeneous equality (alpha ~# ty), when is it OK to-unify alpha := ty?--This note only applied to /homogeneous/ equalities, in which both-sides have the same kind.--There are five reasons not to unify:--1. (SKOL-ESC) Skolem-escape-   Consider the constraint-        forall[2] a[2]. alpha[1] ~ Maybe a[2]-   If we unify alpha := Maybe a, the skolem 'a' may escape its scope.-   The level alpha[1] says that alpha may be used outside this constraint,-   where 'a' is not in scope at all.  So we must not unify.--   Bottom line: when looking at a constraint alpha[n] := ty, do not unify-   if any free variable of 'ty' has level deeper (greater) than n--2. (UNTOUCHABLE) Untouchable unification variables-   Consider the constraint-        forall[2] a[2]. b[1] ~ Int => alpha[1] ~ Int-   There is no (SKOL-ESC) problem with unifying alpha := Int, but it might-   not be the principal solution. Perhaps the "right" solution is alpha := b.-   We simply can't tell.  See "OutsideIn(X): modular type inference with local-   assumptions", section 2.2.  We say that alpha[1] is "untouchable" inside-   this implication.--   Bottom line: at ambient level 'l', when looking at a constraint-   alpha[n] ~ ty, do not unify alpha := ty if there are any given equalities-   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.InertSet--3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs-   This precondition looks at the MetaInfo of the unification variable:--   * TyVarTv: When considering alpha{tyv} ~ ty, if alpha{tyv} is a-     TyVarTv it can only unify with a type variable, not with a-     structured type.  So if 'ty' is a structured type, such as (Maybe x),-     don't unify.--   * CycleBreakerTv: never unified, except by restoreTyVarCycles.--4. (CONCRETE) A ConcreteTv can only unify with a concrete type,-    by definition.--    That is, if we have `rr[conc] ~ F Int`, we can't unify-    `rr` with `F Int`, so we hold off on unifying.-    Note however that the equality might get rewritten; for instance-    if we can rewrite `F Int` to a concrete type, say `FloatRep`,-    then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`.--    Note that we can still make progress on unification even if-    we can't fully solve an equality, e.g.--      alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ]--    we can fill beta[tau] := beta[conc]. This is why we call-    'makeTypeConcrete' in startSolvingByUnification.--5. (COERCION-HOLE) Confusing coercion holes-   Suppose our equality is-     (alpha :: k) ~ (Int |> {co})-   where co :: Type ~ k is an unsolved wanted. Note that this equality-   is homogeneous; both sides have kind k. We refrain from unifying here, because-   of the coercion hole in the RHS -- see Wrinkle (EIK2) in-   Note [Equalities with incompatible kinds] in GHC.Solver.Equality.--Needless to say, all there are wrinkles:--* (SKOL-ESC) Promotion.  Given alpha[n] ~ ty, what if beta[k] is free-  in 'ty', where beta is a unification variable, and k>n?  'beta'-  stands for a monotype, and since it is part of a level-n type-  (equal to alpha[n]), we must /promote/ beta to level n.  Just make-  up a fresh gamma[n], and unify beta[k] := gamma[n].--* (TYVAR-TV) Unification variables.  Suppose alpha[tyv,n] is a level-n-  TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now-  consider alpha[tyv,n] ~ Bool.  We don't want to unify because that-  would break the TyVarTv invariant.--  What about alpha[tyv,n] ~ beta[tau,n], where beta is an ordinary-  TauTv?  Again, don't unify, because beta might later be unified-  with, say Bool.  (If levels permit, we reverse the orientation here;-  see Note [TyVar/TyVar orientation].)--* (UNTOUCHABLE) Untouchability.  When considering (alpha[n] ~ ty), how-  do we know whether there are any given equalities between level n-  and the ambient level?  We answer in two ways:--  * In the eager unifier, we only unify if l=n.  If not, alpha may be-    untouchable, and defer to the constraint solver.  This check is-    made in GHC.Tc.Utils.uUnifilledVar2, in the guard-    isTouchableMetaTyVar.--  * In the constraint solver, we track where Given equalities occur-    and use that to guard unification in-    GHC.Tc.Utils.Unify.touchabilityAndShapeTest. 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-    implication in a separate step, so that they would become touchable.-    But the float/don't-float question turned out to be very delicate,-    as you can see if you look at the long series of Notes associated with-    GHC.Tc.Solver.floatEqualities, around Nov 2020.  It's much easier-    to unify in-place, with no floating.--Note [TyVar/TyVar orientation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Fundeps with instances, and equality orientation]-where the kind equality orientation is important--Given (a ~ b), should we orient the equality as (a~b) or (b~a)?-This is a surprisingly tricky question!--The question is answered by swapOverTyVars, which is used-  - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1-  - in the constraint solver, in GHC.Tc.Solver.Equality.canEqCanLHS2--First note: only swap if you have to!-   See Note [Avoid unnecessary swaps]--So we look for a positive reason to swap, using a three-step test:--* Level comparison. If 'a' has deeper level than 'b',-  put 'a' on the left.  See Note [Deeper level on the left]--* Priority.  If the levels are the same, look at what kind of-  type variable it is, using 'lhsPriority'.--  Generally speaking we always try to put a MetaTv on the left in-  preference to SkolemTv or RuntimeUnkTv, because the MetaTv may be-  touchable and can be unified.--  Tie-breaking rules for MetaTvs:-  - CycleBreakerTv: This is essentially a stand-in for another type;-       it's untouchable and should have the same priority as a skolem: 0.--  - TyVarTv: These can unify only with another tyvar, but we can't unify-       a TyVarTv with a TauTv, because then the TyVarTv could (transitively)-       get a non-tyvar type. So give these a low priority: 1.--  - ConcreteTv: These are like TauTv, except they can only unify with-    a concrete type. So we want to be able to write to them, but not quite-    as much as TauTvs: 2.--  - TauTv: This is the common case; we want these on the left so that they-       can be written to: 3.--  - RuntimeUnkTv: These aren't really meta-variables used in type inference,-       but just a convenience in the implementation of the GHCi debugger.-       Eagerly write to these: 4. See Note [RuntimeUnkTv] in-       GHC.Runtime.Heap.Inspect.--* Names. If the level and priority comparisons are all-  equal, try to eliminate a TyVar with a System Name in-  favour of ones with a Name derived from a user type signature--* Age.  At one point in the past we tried to break any remaining-  ties by eliminating the younger type variable, based on their-  Uniques.  See Note [Eliminate younger unification variables]-  (which also explains why we don't do this any more)--Note [Unification variables on the left]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of-level, so that the unification variable is on the left.--* We /don't/ want this for Givens because if we ave-    [G] a[2] ~ alpha[1]-    [W] Bool ~ a[2]-  we want to rewrite the wanted to Bool ~ alpha[1],-  so we can float the constraint and solve it.--* But for Wanteds putting the unification variable on-  the left means an easier job when floating, and when-  reporting errors -- just fewer cases to consider.--  In particular, we get better skolem-escape messages:-  see #18114--Note [Deeper level on the left]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The most important thing is that we want to put tyvars with-the deepest level on the left.  The reason to do so differs for-Wanteds and Givens, but either way, deepest wins!  Simple.--* Wanteds.  Putting the deepest variable on the left maximise the-  chances that it's a touchable meta-tyvar which can be solved.--* Givens. Suppose we have something like-     forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]--  If we orient the Given a[2] on the left, we'll rewrite the Wanted to-  (beta[1] ~ b[1]), and that can float out of the implication.-  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.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-  skolems, so it's important that skolems have (accurate) level-  numbers.--See #15009 for an further analysis of why "deepest on the left"-is a good plan.--Note [Avoid unnecessary swaps]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we swap without actually improving matters, we can get an infinite loop.-Consider-    work item:  a ~ b-   inert item:  b ~ c-We canonicalise the work-item to (a ~ c).  If we then swap it before-adding to the inert set, we'll add (c ~ a), and therefore kick out the-inert guy, so we get-   new work item:  b ~ c-   inert item:     c ~ a-And now the cycle just repeats--Historical Note [Eliminate younger unification variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given a choice of unifying-     alpha := beta   or   beta := alpha-we try, if possible, to eliminate the "younger" one, as determined-by `ltUnique`.  Reason: the younger one is less likely to appear free in-an existing inert constraint, and hence we are less likely to be forced-into kicking out and rewriting inert constraints.--This is a performance optimisation only.  It turns out to fix-#14723 all by itself, but clearly not reliably so!--It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).-But, to my surprise, it didn't seem to make any significant difference-to the compiler's performance, so I didn't take it any further.  Still-it seemed too nice to discard altogether, so I'm leaving these-notes.  SLPJ Jan 18.--Note [Prevent unification with type families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We prevent unification with type families because of an uneasy compromise.-It's perfectly sound to unify with type families, and it even improves the-error messages in the testsuite. It also modestly improves performance, at-least in some cases. But it's disastrous for test case perf/compiler/T3064.-Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.-What do we do? Do we reduce F? Or do we use the given? Hard to know what's-best. GHC reduces. This is a disaster for T3064, where the type's size-spirals out of control during reduction. If we prevent-unification with type families, then the solver happens to use the equality-before expanding the type family.--It would be lovely in the future to revisit this problem and remove this-extra, unnecessary check. But we retain it for now as it seems to work-better in practice.--Revisited in Nov '20, along with removing flattening variables. Problem-is still present, and the solution is still the same.--Note [Non-TcTyVars in GHC.Tc.Utils.Unify]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because the same code is now shared between unifying types and unifying-kinds, we sometimes will see proper TyVars floating around the unifier.-Example (from test case polykinds/PolyKinds12):--    type family Apply (f :: k1 -> k2) (x :: k1) :: k2-    type instance Apply g y = g y--When checking the instance declaration, we first *kind-check* the LHS-and RHS, discovering that the instance really should be--    type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y--During this kind-checking, all the tyvars will be TcTyVars. Then, however,-as a second pass, we desugar the RHS (which is done in functions prefixed-with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper-TyVars, not TcTyVars, get some kind unification must happen.--Thus, we always check if a TyVar is a TcTyVar before asking if it's a-meta-tyvar.--This used to not be necessary for type-checking (that is, before * :: *)-because expressions get desugared via an algorithm separate from-type-checking (with wrappers, etc.). Types get desugared very differently,-causing this wibble in behavior seen here.--}---- | Breaks apart a function kind into its pieces.-matchExpectedFunKind-  :: TypedThing     -- ^ type, only for errors-  -> Arity           -- ^ n: number of desired arrows-  -> TcKind          -- ^ fun_kind-  -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)--matchExpectedFunKind hs_ty n k = go n k-  where-    go 0 k = return (mkNomReflCo k)--    go n k | Just k' <- coreView k = go n k'--    go n k@(TyVarTy kvar)-      | isMetaTyVar kvar-      = do { maybe_kind <- readMetaTyVar kvar-           ; case maybe_kind of-                Indirect fun_kind -> go n fun_kind-                Flexi ->             defer n k }--    go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })-      | isVisibleFunArg af-      = do { co <- go (n-1) res-           ; return (mkNakedFunCo Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) }--    go n other-     = defer n other--    defer n k-      = do { arg_kinds <- newMetaKindVars n-           ; res_kind  <- newMetaKindVar-           ; let new_fun = mkVisFunTysMany arg_kinds res_kind-                 origin  = TypeEqOrigin { uo_actual   = k-                                        , uo_expected = new_fun-                                        , uo_thing    = Just hs_ty-                                        , uo_visible  = True-                                        }-           ; unifyTypeAndEmit KindLevel origin k new_fun }--{- *********************************************************************-*                                                                      *-                 Checking alpha ~ ty-              for the on-the-fly unifier-*                                                                      *-********************************************************************* -}--data UnifyCheckCaller-  = UC_OnTheFly   -- Called from the on-the-fly unifier-  | UC_QuickLook  -- Called from Quick Look-  | UC_Solver     -- Called from constraint solver-  | UC_Defaulting -- Called when doing top-level defaulting--simpleUnifyCheck :: UnifyCheckCaller -> TcTyVar -> TcType -> Bool--- simpleUnifyCheck does a fast check: True <=> unification is OK--- If it says 'False' then unification might still be OK, but--- it'll take more work to do -- use the full checkTypeEq------ * Rejects if lhs_tv occurs in rhs_ty (occurs check)--- * Rejects foralls unless---      lhs_tv is RuntimeUnk (used by GHCi debugger)---          or is a QL instantiation variable--- * Rejects a non-concrete type if lhs_tv is concrete--- * Rejects type families unless fam_ok=True--- * Does a level-check for type variables, to avoid skolem escape------ This function is pretty heavily used, so it's optimised not to allocate-simpleUnifyCheck caller lhs_tv rhs-  = go rhs-  where--    !(occ_in_ty, occ_in_co) = mkOccFolders lhs_tv--    lhs_tv_lvl         = tcTyVarLevel lhs_tv-    lhs_tv_is_concrete = isConcreteTyVar lhs_tv--    forall_ok = case caller of-                   UC_QuickLook -> isQLInstTyVar lhs_tv-                   _            -> isRuntimeUnkTyVar lhs_tv--    -- This fam_ok thing relates to a very specific perf problem-    -- See Note [Prevent unification with type families]-    -- A couple of QuickLook regression tests rely on unifying with type-    --   families, so we let it through there (not very principled, but let's-    --   see if it bites us)-    fam_ok = case caller of-               UC_Solver     -> True-               UC_QuickLook  -> True-               UC_OnTheFly   -> False-               UC_Defaulting -> True--    go (TyVarTy tv)-      | lhs_tv == tv                                    = False-      | tcTyVarLevel tv `strictlyDeeperThan` lhs_tv_lvl = False-      | lhs_tv_is_concrete, not (isConcreteTyVar tv)    = False-      | occ_in_ty $! (tyVarKind tv)                     = False-      | otherwise                                       = True--    go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})-      | not forall_ok, isInvisibleFunArg af = False-      | otherwise                           = go w && go a && go r--    go (TyConApp tc tys)-      | lhs_tv_is_concrete, not (isConcreteTyCon tc) = False-      | not forall_ok, not (isTauTyCon tc)           = False-      | not fam_ok,    not (isFamFreeTyCon tc)       = False-      | otherwise                                    = all go tys--    go (ForAllTy (Bndr tv _) ty)-      | forall_ok = go (tyVarKind tv) && (tv == lhs_tv || go ty)-      | otherwise = False--    go (AppTy t1 t2)    = go t1 && go t2-    go (CastTy ty co)   = not (occ_in_co co) && go ty-    go (CoercionTy co)  = not (occ_in_co co)-    go (LitTy {})       = True---mkOccFolders :: TcTyVar -> (TcType -> Bool, TcCoercion -> Bool)--- These functions return True---   * if lhs_tv occurs (incl deeply, in the kind of variable)---   * if there is a coercion hole--- No expansion of type synonyms-mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co)-  where-    !(check_ty, _, check_co, _) = foldTyCo occ_folder emptyVarSet-    occ_folder = TyCoFolder { tcf_view  = noView  -- Don't expand synonyms-                            , tcf_tyvar = do_tcv, tcf_covar = do_tcv-                            , tcf_hole  = do_hole-                            , tcf_tycobinder = do_bndr }--    do_tcv is v = Any (not (v `elemVarSet` is) && v == lhs_tv)-                  `mappend` check_ty (varType v)--    do_bndr is tcv _faf = extendVarSet is tcv-    do_hole _is _hole = DM.Any True  -- Reject coercion holes--{- *********************************************************************-*                                                                      *-                 Equality invariant checking-*                                                                      *-********************************************************************* -}---{-  Note [Checking for foralls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We never want to unify-    alpha ~ (forall a. a->a) -> Int-So we look for foralls hidden inside the type, and it's convenient-to do that at the same time as the occurs check (which looks for-occurrences of alpha).--However, it's not just a question of looking for foralls /anywhere/!-Consider-   (alpha :: forall k. k->*)  ~  (beta :: forall k. k->*)-This is legal; e.g. dependent/should_compile/T11635.--We don't want to reject it because of the forall in beta's kind, but-(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type)-we do need to look in beta's kind.  So we carry a flag saying if a-'forall' is OK, and switch the flag on when stepping inside a kind.--Why is it OK?  Why does it not count as impredicative polymorphism?-The reason foralls are bad is because we reply on "seeing" foralls-when doing implicit instantiation.  But the forall inside the kind is-fine.  We'll generate a kind equality constraint-  (forall k. k->*) ~ (forall k. k->*)-to check that the kinds of lhs and rhs are compatible.  If alpha's-kind had instead been-  (alpha :: kappa)-then this kind equality would rightly complain about unifying kappa-with (forall k. k->*)--Note [Forgetful synonyms in checkTyConApp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   type S a b = b   -- Forgets 'a'--   [W] alpha[2] ~ Maybe (S beta[4] gamma[2])--We don't want to promote beta to level 2; rather, we should-expand the synonym. (Currently, in checkTypeEqRhs promotion-is irrevocable, by side effect.)--To avoid this risk we eagerly expand forgetful synonyms.-This also means we won't get an occurs check in-   a ~ Maybe (S a b)--The annoyance is that we might expand the synonym unnecessarily,-something we generally try to avoid.  But for now, this seems-simple.--In a forgetful case like a ~ Maybe (S a b), `checkTyEqRhs` returns-a Reduction that looks-    Reduction { reductionCoercion    = Refl-              , reductionReducedType = Maybe b }-We must jolly well use that reductionReduced type, even though the-reductionCoercion is Refl.  See `canEqCanLHSFinish_no_unification`.--}--data PuResult a b = PuFail CheckTyEqResult-                  | PuOK (Bag a) b--instance Functor (PuResult a) where-  fmap _ (PuFail prob) = PuFail prob-  fmap f (PuOK cts x)  = PuOK cts (f x)--instance Applicative (PuResult a) where-  pure x = PuOK emptyBag x-  PuFail p1 <*> PuFail p2 = PuFail (p1 S.<> p2)-  PuFail p1 <*> PuOK {}   = PuFail p1-  PuOK {}   <*> PuFail p2 = PuFail p2-  PuOK c1 f <*> PuOK c2 x = PuOK (c1 `unionBags` c2) (f x)--instance (Outputable a, Outputable b) => Outputable (PuResult a b) where-  ppr (PuFail prob) = text "PuFail" <+> (ppr prob)-  ppr (PuOK cts x)  = text "PuOK" <> braces-                        (vcat [ text "redn:" <+> ppr x-                              , text "cts:" <+> ppr cts ])--pprPur :: PuResult a b -> SDoc--- For debugging-pprPur (PuFail prob) = text "PuFail:" <> ppr prob-pprPur (PuOK {})     = text "PuOK"--okCheckRefl :: TcType -> TcM (PuResult a Reduction)-okCheckRefl ty = return (PuOK emptyBag (mkReflRedn Nominal ty))--failCheckWith :: CheckTyEqResult -> TcM (PuResult a b)-failCheckWith p = return (PuFail p)--mapCheck :: (x -> TcM (PuResult a Reduction))-         -> [x]-         -> TcM (PuResult a Reductions)-mapCheck f xs-  = do { (ress :: [PuResult a Reduction]) <- mapM f xs-       ; return (unzipRedns <$> sequenceA ress) }-         -- sequenceA :: [PuResult a Reduction] -> PuResult a [Reduction]-         -- unzipRedns :: [Reduction] -> Reductions---------------------------------- | Options describing how to deal with a type equality--- in the pure unifier. See 'checkTyEqRhs'-data TyEqFlags a-  = TEF { tef_foralls  :: Bool         -- Allow foralls-        , tef_lhs      :: CanEqLHS     -- LHS of the constraint-        , tef_unifying :: AreUnifying  -- Always NotUnifying if tef_lhs is TyFamLHS-        , tef_fam_app  :: TyEqFamApp a-        , tef_occurs   :: CheckTyEqProblem }  -- Soluble or insoluble occurs check---- | What to do when encountering a type-family application while processing--- a type equality in the pure unifier.------ See Note [Family applications in canonical constraints]-data TyEqFamApp a-  = TEFA_Fail                    -- Always fail-  | TEFA_Recurse                 -- Just recurse-  | TEFA_Break (FamAppBreaker a) -- Recurse, but replace with cycle breaker if fails,-                                 -- using the FamAppBreaker--data AreUnifying-  = Unifying-       MetaInfo         -- MetaInfo of the LHS tyvar (which is a meta-tyvar)-       TcLevel          -- Level of the LHS tyvar-       LevelCheck--  | NotUnifying         -- Not attempting to unify--data LevelCheck-  = LC_None       -- Level check not needed: we should never encounter-                  -- a tyvar at deeper level than the LHS--  | LC_Check      -- Do a level check between the LHS tyvar and the occurrence tyvar-                  -- Fail if the level check fails--  | LC_Promote    -- Do a level check between the LHS tyvar and the occurrence tyvar-                  -- If the level check fails, and the occurrence is a unification-                  -- variable, promote it-      Bool        --   False <=> don't promote under type families (the common case)-                  --   True  <=> promote even under type families-                  --             see Note [Defaulting equalities] in GHC.Tc.Solver--instance Outputable (TyEqFlags a) where-  ppr (TEF { .. }) = text "TEF" <> braces (-                        vcat [ text "tef_foralls =" <+> ppr tef_foralls-                             , text "tef_lhs =" <+> ppr tef_lhs-                             , text "tef_unifying =" <+> ppr tef_unifying-                             , text "tef_fam_app =" <+> ppr tef_fam_app-                             , text "tef_occurs =" <+> ppr tef_occurs ])--instance Outputable (TyEqFamApp a) where-  ppr TEFA_Fail       = text "TEFA_Fail"-  ppr TEFA_Recurse    = text "TEFA_Recurse"-  ppr (TEFA_Break {}) = text "TEFA_Break"--instance Outputable AreUnifying where-  ppr NotUnifying = text "NotUnifying"-  ppr (Unifying mi lvl lc) = text "Unifying" <+>-         braces (ppr mi <> comma <+> ppr lvl <> comma <+> ppr lc)--instance Outputable LevelCheck where-  ppr LC_None        = text "LC_None"-  ppr LC_Check       = text "LC_Check"-  ppr (LC_Promote b) = text "LC_Promote" <> ppWhen b (text "(deep)")--famAppArgFlags :: TyEqFlags a -> TyEqFlags a--- Adjust the flags when going undter a type family--- Only the outer family application gets the loop-breaker treatment--- Ditto tyvar promotion.  E.g.---        [W] alpha[2] ~ Maybe (F beta[3])--- Do not promote beta[3]; instead promote (F beta[3])-famAppArgFlags flags@(TEF { tef_unifying = unifying })-  = flags { tef_fam_app  = TEFA_Recurse-          , tef_unifying = zap_promotion unifying-          , tef_occurs   = cteSolubleOccurs }-            -- tef_occurs: under a type family, an occurs check is not definitely-insoluble-  where-    zap_promotion (Unifying info lvl (LC_Promote deeply))-              | not deeply = Unifying info lvl LC_Check-    zap_promotion unifying = unifying--type FamAppBreaker a = TcType -> TcM (PuResult a Reduction)-     -- Given a family-application ty, return a Reduction :: ty ~ cvb-     -- where 'cbv' is a fresh loop-breaker tyvar (for Given), or-     -- just a fresh TauTv (for Wanted)--checkTyEqRhs :: forall a. TyEqFlags a-                       -> TcType           -- Already zonked-                       -> TcM (PuResult a Reduction)-checkTyEqRhs flags ty-  = case ty of-      LitTy {}        -> okCheckRefl ty-      TyConApp tc tys -> checkTyConApp flags ty tc tys-      TyVarTy tv      -> checkTyVar flags tv-        -- Don't worry about foralls inside the kind; see Note [Checking for foralls]-        -- Nor can we expand synonyms; see Note [Occurrence checking: look inside kinds]-        --                             in GHC.Core.FVs--      FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}-       | isInvisibleFunArg af  -- e.g.  Num a => blah-       , not (tef_foralls flags)-       -> failCheckWith impredicativeProblem -- Not allowed (TyEq:F)-       | otherwise-       -> do { w_res <- checkTyEqRhs flags w-             ; a_res <- checkTyEqRhs flags a-             ; r_res <- checkTyEqRhs flags r-             ; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) }--      AppTy fun arg -> do { fun_res <- checkTyEqRhs flags fun-                          ; arg_res <- checkTyEqRhs flags arg-                          ; return (mkAppRedn <$> fun_res <*> arg_res) }--      CastTy ty co  -> do { ty_res <- checkTyEqRhs flags ty-                          ; co_res <- checkCo flags co-                          ; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) }--      CoercionTy co -> do { co_res <- checkCo flags co-                          ; return (mkReflCoRedn Nominal <$> co_res) }--      ForAllTy {}-         | tef_foralls flags -> okCheckRefl ty-         | otherwise         -> failCheckWith impredicativeProblem  -- Not allowed (TyEq:F)-----------------------checkCo :: TyEqFlags a -> Coercion -> TcM (PuResult a Coercion)--- See Note [checkCo]-checkCo (TEF { tef_lhs = TyFamLHS {} }) co-  = return (pure co)--checkCo (TEF { tef_lhs = TyVarLHS lhs_tv-             , tef_unifying = unifying-             , tef_occurs = occ_prob }) co-  -- Check for coercion holes, if unifying-  -- See (COERCION-HOLE) in Note [Unification preconditions]-  | hasCoercionHoleCo co-  = failCheckWith (cteProblem cteCoercionHole)--  -- Occurs check (can promote)-  | Unifying _ lhs_tv_lvl (LC_Promote {}) <- unifying-  = do { reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfCo co)-       ; if cterHasNoProblem reason-         then return (pure co)-         else failCheckWith reason }--  -- Occurs check (no promotion)-  | lhs_tv `elemVarSet` tyCoVarsOfCo co-  = failCheckWith (cteProblem occ_prob)--  | otherwise-  = return (pure co)--{- Note [checkCo]-~~~~~~~~~~~~~~~~~-We don't often care about the contents of coercions, so checking-coercions before making an equality constraint may be surprising.-But there are several cases we need to be wary of:--(1) When we're unifying a variable, we must make sure that the variable-    appears nowhere on the RHS -- even in a coercion. Otherwise, we'll-    create a loop.--(2) We must still make sure that no variable in a coercion is at too-    high a level. But, when unifying, we can promote any variables we encounter.--(3) We do not unify variables with a type with a free coercion hole.-    See (COERCION-HOLE) in Note [Unification preconditions].---Note [Promotion and level-checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-"Promotion" happens when we have this:--  [W] w1: alpha[2] ~ Maybe beta[4]--Here we must NOT unify alpha := Maybe beta, because beta may turn out-to stand for a type involving some inner skolem.  Yikes!-Skolem-escape.  So instead we /promote/ beta, like this:--  beta[4] := beta'[2]-  [W] w1: alpha[2] ~ Maybe beta'[2]--Now we can unify alpha := Maybe beta', which might unlock other-constraints.  But if some other constraint wants to unify beta with a-nested skolem, it'll get stuck with a skolem-escape error.--Now consider `w2` where a type family is involved (#22194):--  [W] w2: alpha[2] ~ Maybe (F gamma beta[4])--In `w2`, it may or may not be the case that `beta` is level 2; suppose-we later discover gamma := Int, and type instance F Int _ = Int.-So, instead, we promote the entire funcion call:--  [W] w2': alpha[2] ~ Maybe gamma[2]-  [W] w3:  gamma[2] ~ F gamma beta[4]--Now we can unify alpha := Maybe gamma, which is a Good Thng.--Wrinkle (W1)--There is an important wrinkle: /all this only applies when unifying/.-For example, suppose we have- [G] a[2] ~ Maybe b[4]-where 'a' is a skolem.  This Given might arise from a GADT match, and-we can absolutely use it to rewrite locally. In fact we must do so:-that is how we exploit local knowledge about the outer skolem a[2].-This applies equally for a Wanted [W] a[2] ~ Maybe b[4]. Using it for-local rewriting is fine. (It's not clear to me that it is /useful/,-but it's fine anyway.)--So we only do the level-check in checkTyVar when /unifying/ not for-skolems (or untouchable unification variables).--Note [Family applications in canonical constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A constraint with a type family application in the RHS needs special care.--* First, occurs checks.  If we have-     [G] a ~ Maybe (F (Maybe a))-     [W] alpha ~ Maybe (F (Maybe alpha))-  it looks as if we have an occurs check.  But go read-  Note [Type equality cycles] in GHC.Tc.Solver.Equality--  The same considerations apply when the LHS is a type family:-     [G] G a ~ Maybe (F (Maybe (G a)))-     [W] G alpha ~ Maybe (F (Maybe (G alpha)))--* Second, promotion. If we have (#22194)-     [W] alpha[2] ~ Maybe (F beta[4])-  it is wrong to promote beta.  Instead we want to split to-     [W] alpha[2] ~ Maybe gamma[2]-     [W] gamma[2] ~ F beta[4]-  See Note [Promotion and level-checking] above.--* Third, concrete type variables.  If we have-     [W] alpha[conc] ~ Maybe (F tys)-  we want to add an extra variable thus:-     [W] alpha[conc] ~ Maybe gamma[conc]-     [W] gamma[conc] ~ F tys-  Now we can unify alpha, and that might unlock something else.--In all these cases we want to create a fresh type variable, and-emit a new equality connecting it to the type family application.--The `tef_fam_app` field of `TypeEqFlags` says what to do at a type-family application in the RHS of the constraint.  `TEFA_Fail` and-`TEFA_Recurse` are straightforward.  `TEFA_Break` is the clever-one. As you can see in `checkFamApp`, it-  * Checks the arguments, but using `famAppArgFlags` to record that-    we are now "under" a type-family application. It `tef_fam_app` to-    `TEFA_Recurse`.-  * If any of the arguments fail (level-check error, occurs check)-    use the `FamAppBreaker` to create the extra binding.--Note that this always cycle-breaks the /outermost/ family application.-If we have  [W] alpha ~ Maybe (F (G alpha))-* We'll use checkFamApp on `(F (G alpha))`-* It will recurse into `(G alpha)` with TEFA_Recurse, but not cycle-break it-* The occurs check will fire when we hit `alpha`-* `checkFamApp` on `(F (G alpha))` will see the failure and invoke-  the `FamAppBreaker`.--}----------------------checkTyConApp :: TyEqFlags a-              -> TcType -> TyCon -> [TcType]-              -> TcM (PuResult a Reduction)-checkTyConApp flags@(TEF { tef_unifying = unifying, tef_foralls = foralls_ok })-              tc_app tc tys-  | isTypeFamilyTyCon tc-  , let arity = tyConArity tc-  = if tys `lengthIs` arity-    then checkFamApp flags tc_app tc tys  -- Common case-    else do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys-                  fun_app                = mkTyConApp tc fun_args-            ; fun_res   <- checkFamApp flags fun_app tc fun_args-            ; extra_res <- mapCheck (checkTyEqRhs flags) extra_args-            ; traceTc "Over-sat" (ppr tc <+> ppr tys $$ ppr arity $$ pprPur fun_res $$ pprPur extra_res)-            ; return (mkAppRedns <$> fun_res <*> extra_res) }--  | Just ty' <- rewriterView tc_app-       -- e.g. S a  where  type S a = F [a]-       --             or   type S a = Int-       -- See Note [Forgetful synonyms in checkTyConApp]-  = checkTyEqRhs flags ty'--  | not (isTauTyCon tc || foralls_ok)-  = failCheckWith impredicativeProblem--  | Unifying info _ _ <- unifying-  , isConcreteInfo info-  , not (isConcreteTyCon tc)-  = failCheckWith (cteProblem cteConcrete)--  | otherwise  -- Recurse on arguments-  = recurseIntoTyConApp flags tc tys--recurseIntoTyConApp :: TyEqFlags a -> TyCon -> [TcType] -> TcM (PuResult a Reduction)-recurseIntoTyConApp flags tc tys-  = do { tys_res <- mapCheck (checkTyEqRhs flags) tys-       ; return (mkTyConAppRedn Nominal tc <$> tys_res) }----------------------checkFamApp :: TyEqFlags a-            -> TcType -> TyCon -> [TcType]  -- Saturated family application-            -> TcM (PuResult a Reduction)--- See Note [Family applications in canonical constraints]-checkFamApp flags@(TEF { tef_unifying = unifying, tef_occurs = occ_prob-                       , tef_fam_app = fam_app_flag, tef_lhs = lhs })-            fam_app tc tys-  = case fam_app_flag of-      TEFA_Fail -> failCheckWith (cteProblem cteTypeFamily)--      -- Occurs check: F ty ~ ...(F ty)...-      _ | TyFamLHS lhs_tc lhs_tys <- lhs-        , tcEqTyConApps lhs_tc lhs_tys tc tys-        -> case fam_app_flag of-             TEFA_Recurse       -> failCheckWith (cteProblem occ_prob)-             TEFA_Break breaker -> breaker fam_app--      _ | Unifying lhs_info _ _ <- unifying-        , isConcreteInfo lhs_info-        -> case fam_app_flag of-             TEFA_Recurse       -> failCheckWith (cteProblem cteConcrete)-             TEFA_Break breaker -> breaker fam_app--      TEFA_Recurse-        -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys-              ; traceTc "under" (ppr tc $$ pprPur tys_res $$ ppr flags)-              ; return (mkTyConAppRedn Nominal tc <$> tys_res) }--      -- For TEFA_Break, try recursion; and break if there is a problem-      -- e.g.  alpha[2] ~ Maybe (F beta[2])    No problem: just unify-      --       alpha[2] ~ Maybe (F beta[4])    Level-check problem: break-      -- NB: in the latter case, don't promote beta[4]; hence arg_flags!-      TEFA_Break breaker-        -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys-              ; case tys_res of-                  PuOK cts redns -> return (PuOK cts (mkTyConAppRedn Nominal tc redns))-                  PuFail {}      -> breaker fam_app }-  where-    arg_flags = famAppArgFlags flags----------------------checkTyVar :: forall a. TyEqFlags a -> TcTyVar -> TcM (PuResult a Reduction)-checkTyVar (TEF { tef_lhs = lhs, tef_unifying = unifying, tef_occurs = occ_prob }) occ_tv-  = case lhs of-      TyFamLHS {}     -> success   -- Nothing to do if the LHS is a type-family-      TyVarLHS lhs_tv -> check_tv unifying lhs_tv-  where-    lvl_occ = tcTyVarLevel occ_tv-    success = okCheckRefl (mkTyVarTy occ_tv)--    ----------------------    check_tv NotUnifying lhs_tv-      = simple_occurs_check lhs_tv-      -- We need an occurs-check here, but no level check-      -- See Note [Promotion and level-checking] wrinkle (W1)--    check_tv (Unifying info lvl prom) lhs_tv-      = do { mb_done <- isFilledMetaTyVar_maybe occ_tv-           ; case mb_done of-               Just {} -> success-               -- Already promoted; job done-               -- Example alpha[2] ~ Maybe (beta[4], beta[4])-               -- We promote the first occurrence, and then encounter it-               -- a second time; we don't want to re-promote it!-               -- Remember, the entire process started with a fully zonked type--               Nothing -> check_unif info lvl prom lhs_tv }--    ----------------------    -- We are in the Unifying branch of AreUnifying; and occ_tv is unfilled-    check_unif :: MetaInfo -> TcLevel -> LevelCheck-               -> TcTyVar -> TcM (PuResult a Reduction)-    check_unif lhs_tv_info lhs_tv_lvl prom lhs_tv-      | isConcreteInfo lhs_tv_info-      , not (isConcreteTyVar occ_tv)-      = if can_make_concrete occ_tv-        then promote lhs_tv lhs_tv_info lhs_tv_lvl-        else failCheckWith (cteProblem cteConcrete)--      | lvl_occ `strictlyDeeperThan` lhs_tv_lvl-      = case prom of-           LC_None    -> pprPanic "check_unif" (ppr lhs_tv $$ ppr occ_tv)-           LC_Check   -> failCheckWith (cteProblem cteSkolemEscape)-           LC_Promote {}-             | isSkolemTyVar occ_tv  -> failCheckWith (cteProblem cteSkolemEscape)-             | otherwise             -> promote lhs_tv lhs_tv_info lhs_tv_lvl--      | otherwise-      = simple_occurs_check lhs_tv--    ----------------------    simple_occurs_check lhs_tv-      | lhs_tv == occ_tv || check_kind (tyVarKind occ_tv)-      = failCheckWith (cteProblem occ_prob)-      | otherwise-      = success-      where-        (check_kind, _) = mkOccFolders lhs_tv--    ----------------------    can_make_concrete occ_tv = case tcTyVarDetails occ_tv of-      MetaTv { mtv_info = info } -> case info of-                                      ConcreteTv {} -> True-                                      TauTv {}      -> True-                                      _             -> False-      _ -> False  -- Don't attempt to make other type variables concrete-                  -- (e.g. SkolemTv, TyVarTv, CycleBreakerTv, RuntimeUnkTv).--    ----------------------    -- occ_tv is definitely a MetaTyVar-    promote lhs_tv lhs_tv_info lhs_tv_lvl-      | MetaTv { mtv_info = info_occ, mtv_tclvl = lvl_occ } <- tcTyVarDetails occ_tv-      = do { let new_info | isConcreteInfo lhs_tv_info = lhs_tv_info-                          | otherwise                  = info_occ-                 new_lvl = lhs_tv_lvl `minTcLevel` lvl_occ-                           -- c[conc,3] ~ p[tau,2]: want to clone p:=p'[conc,2]-                           -- c[tau,2]  ~ p[tau,3]: want to clone p:=p'[tau,2]--           -- Check the kind of occ_tv-           ; reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfType (tyVarKind occ_tv))--           ; if cterHasNoProblem reason  -- Successfully promoted-             then do { new_tv_ty <- promote_meta_tyvar new_info new_lvl occ_tv-                     ; okCheckRefl new_tv_ty }-             else failCheckWith reason }--      | otherwise = pprPanic "promote" (ppr occ_tv)----------------------------checkPromoteFreeVars :: CheckTyEqProblem    -- What occurs check problem to report-                     -> TcTyVar -> TcLevel-                     -> TyCoVarSet -> TcM CheckTyEqResult--- Check this set of TyCoVars for---   (a) occurs check---   (b) promote if necessary, or report skolem escape-checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl vs-  = do { oks <- mapM do_one (nonDetEltsUniqSet vs)-       ; return (mconcat oks) }-  where-    do_one :: TyCoVar -> TcM CheckTyEqResult-    do_one v | isCoVar v           = return cteOK-             | lhs_tv == v         = return (cteProblem occ_prob)-             | no_promotion        = return cteOK-             | not (isMetaTyVar v) = return (cteProblem cteSkolemEscape)-             | otherwise           = promote_one v-      where-        no_promotion = not (tcTyVarLevel v `strictlyDeeperThan` lhs_tv_lvl)--    -- isCoVar case: coercion variables are not an escape risk-    -- If an implication binds a coercion variable, it'll have equalities,-    -- so the "intervening given equalities" test above will catch it-    -- Coercion holes get filled with coercions, so again no problem.--    promote_one tv = do { _ <- promote_meta_tyvar TauTv lhs_tv_lvl tv-                        ; return cteOK }--promote_meta_tyvar :: MetaInfo -> TcLevel -> TcTyVar -> TcM TcType-promote_meta_tyvar info dest_lvl occ_tv-  = do { -- Check whether occ_tv is already unified. The rhs-type-         -- started zonked, but we may have promoted one of its type-         -- variables, and we then encounter it for the second time.-         -- But if so, it'll definitely be another already-checked TyVar-         mb_filled <- isFilledMetaTyVar_maybe occ_tv-       ; case mb_filled of {-           Just ty -> return ty ;-           Nothing ->--    -- OK, not done already, so clone/promote it-    do { new_tv <- cloneMetaTyVarWithInfo info dest_lvl occ_tv-       ; liftZonkM $ writeMetaTyVar occ_tv (mkTyVarTy new_tv)-       ; traceTc "promoteTyVar" (ppr occ_tv <+> text "-->" <+> ppr new_tv)-       ; return (mkTyVarTy new_tv) } } }------------------------------touchabilityAndShapeTest :: TcLevel -> TcTyVar -> TcType -> Bool--- This is the key test for untouchability:--- See Note [Unification preconditions] in GHC.Tc.Utils.Unify--- and Note [Solve by unification] in GHC.Tc.Solver.Equality--- True <=> touchability and shape are OK-touchabilityAndShapeTest given_eq_lvl tv rhs-  | MetaTv { mtv_info = info, mtv_tclvl = tv_lvl } <- tcTyVarDetails tv-  , tv_lvl `deeperThanOrSame` given_eq_lvl-  , checkTopShape info rhs-  = True-  | otherwise-  = False------------------------------ | checkTopShape checks (TYVAR-TV)--- Note [Unification preconditions]; returns True if these conditions--- are satisfied. But see the Note for other preconditions, too.-checkTopShape :: MetaInfo -> TcType -> Bool-checkTopShape info xi-  = case info of-      TyVarTv ->-        case getTyVar_maybe xi of   -- Looks through type synonyms-           Nothing -> False-           Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle-                        SkolemTv {} -> True-                        RuntimeUnk  -> True-                        MetaTv { mtv_info = TyVarTv } -> True-                        _                             -> False-      CycleBreakerTv -> False  -- We never unify these-      _ -> True+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE DerivingStrategies  #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE RecursiveDo         #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE TypeApplications    #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++-- | Type subsumption and unification+module GHC.Tc.Utils.Unify (+  -- Full-blown subsumption+  tcWrapResult, tcWrapResultO, tcWrapResultMono,+  tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS,+  addSubTypeCtxt,+  tcSubTypeAmbiguity, tcSubMult,+  checkConstraints, checkTvConstraints,+  buildImplicationFor, buildTvImplication, emitResidualTvConstraint,++  -- Skolemisation+  DeepSubsumptionFlag(..), getDeepSubsumptionFlag, isRhoTyDS,+  tcSkolemise, tcSkolemiseCompleteSig, tcSkolemiseExpectedType,+  dsInstantiate,++  -- Various unifications+  unifyType, unifyKind, unifyInvisibleType,+  unifyExprType, unifyTypeAndEmit, promoteTcType,+  swapOverTyVars, touchabilityTest, checkTopShape, lhsPriority,+  UnifyEnv(..), updUEnvLoc, setUEnvRole,+  uType,+  mightEqualLater,+  makeTypeConcrete,++  --------------------------------+  -- Holes+  matchExpectedListTy,+  matchExpectedTyConApp,+  matchExpectedAppTy,+  matchExpectedFunTys,+  matchExpectedFunKind,+  matchActualFunTy, matchActualFunTys,++  checkTyEqRhs, recurseIntoTyConApp, recurseIntoFamTyConApp,+  PuResult(..), okCheckRefl, mapCheck,+  TyEqFlags(..),+  notUnifying_TEFTask, unifyingLHSMetaTyVar_TEFTask, defaulting_TEFTask,+  pureTyEqFlags_LHSMetaTyVar, mkTEFA_Break,++  OccursCheck(..), LevelCheck(..), ConcreteCheck(..),+  TyEqFamApp(..), FamAppBreaker(..),+  checkPromoteFreeVars,++  simpleUnifyCheck, UnifyCheckCaller(..), SimpleUnifyResult(..),++  fillInferResult, fillInferResultNoInst+  ) where++import GHC.Prelude++import GHC.Hs++import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) )+import GHC.Tc.Errors.Ppr   ( pprErrCtxtMsg )+import GHC.Tc.Utils.Concrete+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcMType+import GHC.Tc.Utils.TcType+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.CtLoc( CtLoc, mkKindEqLoc, adjustCtLoc, updateCtLocOrigin, ctLocOrigin )+import GHC.Tc.Types.Origin+import GHC.Tc.Zonk.TcType+import GHC.Tc.Utils.TcMType qualified as TcM++import GHC.Tc.Solver.InertSet++import GHC.Core.Type+import GHC.Core.TyCo.Rep hiding (Refl)+import GHC.Core.TyCo.FVs( isInjectiveInType )+import GHC.Core.TyCo.Ppr( debugPprType {- pprTyVar -} )+import GHC.Core.TyCon+import GHC.Core.Coercion+import GHC.Core.Unify+import GHC.Core.Predicate( EqRel(..), mkEqPredRole, mkNomEqPred )+import GHC.Core.Multiplicity+import GHC.Core.Reduction++import qualified GHC.LanguageExtensions as LangExt++import GHC.Builtin.Types+import GHC.Types.Name+import GHC.Types.Id( idType )+import GHC.Types.Var as Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Basic+import GHC.Types.Unique.Set (nonDetEltsUniqSet)++import GHC.Utils.Misc+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic++import GHC.Driver.DynFlags++import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.Maybe (firstJusts)++import Control.Monad+import Data.Functor.Identity (Identity(..))+import qualified Data.List.NonEmpty as NE+import Data.Monoid as DM ( Any(..) )+import qualified Data.Semigroup as S ( (<>) )+import Data.Traversable (for)++{- *********************************************************************+*                                                                      *+              matchActualFunTys+*                                                                      *+********************************************************************* -}++-- | 'matchActualFunTy' looks for just one function arrow,+-- returning an uninstantiated sigma-type.+--+-- Invariant: the returned argument type has a syntactically fixed+-- RuntimeRep in the sense of Note [Fixed RuntimeRep]+-- in GHC.Tc.Utils.Concrete.+--+-- See Note [Return arguments with a fixed RuntimeRep].+matchActualFunTy+  :: ExpectedFunTyOrigin+      -- ^ See Note [Herald for matchExpectedFunTys]+  -> Maybe TypedThing+      -- ^ The thing with type TcSigmaType+  -> (Arity, TcType)+      -- ^ Total number of value args in the call, and+      --   the original function type+      -- (Both are used only for error messages)+  -> TcRhoType+      -- ^ Type to analyse: a TcRhoType+  -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)+-- This function takes in a type to analyse (a RhoType) and returns+-- an argument type and a result type (splitting apart a function arrow).+-- The returned argument type is a SigmaType with a fixed RuntimeRep;+-- as explained in Note [Return arguments with a fixed RuntimeRep].+--+-- See Note [matchActualFunTy error handling] for the first three arguments++-- If   (wrap, arg_ty, res_ty) = matchActualFunTy ... fun_ty+-- then wrap :: fun_ty ~> (arg_ty -> res_ty)+-- and NB: res_ty is an (uninstantiated) SigmaType++matchActualFunTy herald mb_thing err_info fun_ty+  = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $+    go fun_ty+  where+    -- Does not allocate unnecessary meta variables: if the input already is+    -- a function, we just take it apart.  Not only is this efficient,+    -- it's important for higher rank: the argument might be of form+    --              (forall a. ty) -> other+    -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd+    -- hide the forall inside a meta-variable+    go :: TcRhoType   -- The type we're processing, perhaps after+                      -- expanding type synonyms+       -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)+    go ty | Just ty' <- coreView ty = go ty'++    go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })+      = assert (isVisibleFunArg af) $+      do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty+         ; return (idHsWrapper, Scaled w arg_ty, res_ty) }++    go ty@(TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty' -> go ty'+               Flexi        -> defer ty }++       -- In all other cases we bale out into ordinary unification+       -- However unlike the meta-tyvar case, we are sure that the+       -- number of arguments doesn't match arity of the original+       -- type, so we can add a bit more context to the error message+       -- (cf #7869).+       --+       -- It is not always an error, because specialized type may have+       -- different arity, for example:+       --+       -- > f1 = f2 'a'+       -- > f2 :: Monad m => m Bool+       -- > f2 = undefined+       --+       -- But in that case we add specialized type into error context+       -- anyway, because it may be useful. See also #9605.+    go ty = addErrCtxtM (mk_ctxt ty) (defer ty)++    ------------+    defer fun_ty+      = do { arg_ty <- new_check_arg_ty herald 1+           ; res_ty <- newOpenFlexiTyVarTy+           ; let unif_fun_ty = mkScaledFunTys [arg_ty] res_ty+           ; co <- unifyType mb_thing fun_ty unif_fun_ty+           ; return (mkWpCastN co, arg_ty, res_ty) }++    ------------+    mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)+    mk_ctxt _res_ty = mkFunTysMsg herald err_info++{- Note [matchActualFunTy error handling]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+matchActualFunTy is made much more complicated by the+desire to produce good error messages. Consider the application+    f @Int x y+In GHC.Tc.Gen.Head.tcInstFun we instantiate the function type, one+argument at a time.  It must instantiate any type/dictionary args,+before looking for an arrow type.++But if it doesn't find an arrow type, it wants to generate a message+like "f is applied to two arguments but its type only has one".+To do that, it needs to know about the args that tcArgs has already+munched up -- hence passing in n_val_args_in_call and arg_tys_so_far;+and hence also the accumulating so_far arg to 'go'.++This allows us (in mk_ctxt) to construct f's /instantiated/ type,+with just the values-arg arrows, which is what we really want+in the error message.++Ugh!+-}++-- | Like 'matchExpectedFunTys', but used when you have an "actual" type,+-- for example in function application.+--+-- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep+-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+-- See Note [Return arguments with a fixed RuntimeRep].+matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys]+                  -> CtOrigin+                  -> Arity+                  -> TcSigmaType+                  -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType)+-- If    matchActualFunTys n ty = (wrap, [t1,..,tn], res_ty)+-- then  wrap : ty ~> (t1 -> ... -> tn -> res_ty)+--       and res_ty is a RhoType+-- NB: the returned type is top-instantiated; it's a RhoType+matchActualFunTys herald ct_orig n_val_args_wanted top_ty+  = go n_val_args_wanted [] top_ty+  where+    go n so_far fun_ty+      | not (isRhoTy fun_ty)+      = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty+           ; (wrap2, arg_tys, res_ty) <- go n so_far rho+           ; return (wrap2 <.> wrap1, arg_tys, res_ty) }++    go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)++    go n so_far fun_ty+      = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTy+                                                 herald Nothing+                                                 (n_val_args_wanted, top_ty)+                                                 fun_ty+           ; (wrap_res, arg_tys, res_ty)   <- go (n-1) (arg_ty1:so_far) res_ty1+           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty+           -- NB: arg_ty1 comes from matchActualFunTy, so it has+           -- a syntactically fixed RuntimeRep as needed to call mkWpFun.+           ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }++{-+************************************************************************+*                                                                      *+          Skolemisation and matchExpectedFunTys+*                                                                      *+************************************************************************++Note [Skolemisation overview]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose f :: (forall a. a->a) -> blah, and we have the application (f e)+Then we want to typecheck `e` pushing in the type `forall a. a->a`. But we+need to be careful:++* Roughly speaking, in (tcPolyExpr e (forall a b. rho)), we skolemise `a` and `b`,+  and then call (tcExpr e rho)++* But not quite!  We must be careful if `e` is a type lambda (\ @p @q -> blah).+  Then we want to line up the skolemised variables `a`,`b`+  with `p`,`q`, so we can't just call (tcExpr (\ @p @q -> blah) rho)++* A very similar situation arises with+     (\ @p @q -> blah) :: forall a b. rho+  Again, we must line up `p`, `q` with the skolemised `a` and `b`.++* Another similar situation arises with+    g :: forall a b. rho+    g @p @q x y = ....+  Here again when skolemising `a` and `b` we must be careful to match them up+  with `p` and `q`.++OK, so how exactly do we check @p binders in lambdas?  First note that we only+we only attempt to deal with @p binders when /checking/. We don't do inference for+(\ @a -> blah), not yet anyway.++For checking, there are two cases to consider:+  * Function LHS, where the function has a type signature+                  f :: forall a. a -> forall b. [b] -> blah+                  f @p x @q y = ...++  * Lambda        \ @p x @q y -> ...+                  \cases { @p x @q y -> ... }+    (\case p behaves like \cases { p -> ... }, and p is always a term pattern.)++Both ultimately handled by matchExpectedFunTys.++* Function LHS case is handled by `GHC.Tc.Gen.Bind.tcPolyCheck`:+  * It calls `tcSkolemiseCompleteSig`+  * Passes the skolemised variables into `tcFunBindMatches`+  * Which uses `matchExpectedFunTys` to decompose the function type to+    match the arguments+  * And then passes the (skolemised-variables ++ arg tys) on to `tcMatches`++* For the Lambda case there are two sub-cases:+   * An expression with a type signature: (\ @a x y -> blah) :: hs_ty+     This is handled by `GHC.Tc.Gen.Head.tcExprWithSig`, which kind-checks+     the signature and hands off to `tcExprPolyCheck` via `tcPolyLExprSig`.+     Note that the foralls at the top of hs_ty scope over the expression.++   * A higher order call: h e, where h :: poly_ty -> blah+     This is handlded by `GHC.Tc.Gen.Expr.tcPolyExpr`, which (in the+     checking case) again hands off to `tcExprPolyCheck`.  Here there is+     no type-variable scoping to worry about.++  So both sub-cases end up in `GHC.Tc.Gen.Expr.tcPolyExprCheck`+  * This skolemises the /top-level/ invisible binders, but remembers+    the binders as [ExpPatType]+  * Then it looks for a lambda, and if so, calls `tcLambdaMatches` passing in+    the skolemised binders so they can be matched up with the lambda binders.+  * Otherwise it does deep-skolemisation if DeepSubsumption is on,+    and then calls tcExpr to typecheck `e`++  The outer skolemisation in tcPolyExprCheck is done using+    * tcSkolemiseCompleteSig when there is a user-written signature+    * tcSkolemiseGeneral when the polytype just comes from the context e.g. (f e)+  The former just calls the latter, so the two cases differ only slightly:+    * Both do shallow skolemisation+    * Both go via checkConstraints, which uses implicationNeeded to decide whether+      to build an implication constraint even if there /are/ no skolems.+      See Note [When to build an implication] below.++  The difference between the two cases is that `tcSkolemiseCompleteSig`+  also brings the outer type variables into scope.  It would do no+  harm to do so in both cases, but I found that (to my surprise) doing+  so caused a non-trivial (1%-ish) perf hit on the compiler.++* `tcFunBindMatches` and `tcLambdaMatches` both use `matchExpectedFunTys`, which+  ensures that any trailing invisible binders are skolemised; and does so deeply+  if DeepSubsumption is on.++  This corresponds to the plan: "skolemise at the '=' of a function binding or+  at the '->' of a lambda binding".  (See #17594 and "Plan B2".)++Some wrinkles++(SK1) tcSkolemiseGeneral and tcSkolemiseCompleteSig make fresh type variables+      See Note [Instantiate sig with fresh variables]++(SK2) All skolemisation (even without DeepSubsumption) builds just one implication+      constraint for a nested forall like:+          forall a. Eq a => forall b. Ord b => blah+      The implication constraint will look like+          forall a b. (Eq a, Ord b) => <constraints>+      See the loop in GHC.Tc.Utils.Instantiate.topSkolemise.+      and Note [Skolemisation en-bloc] in that module+++Some examples:++*     f :: forall a b. blah+      f @p x = rhs+  `tcPolyCheck` calls `tcSkolemiseCompleteSig` to skolemise the signature, and+  then calls `tcFunBindMatches` passing in [a_sk, b_sk], the skolemsed+  variables. The latter ultimately calls `tcMatches`, and thence `tcMatchPats`.+  The latter matches up the `a_sk` with `@p`, and discards the `b_sk`.++*     f :: forall (a::Type) (b::a). blah+      f @(p::b) x = rhs+  `tcSkolemiseCompleteSig` brings `a` and `b` into scope, bound to `a_sk` and `b_sk` resp.+  When `tcMatchPats` typechecks the pattern `@(p::b)` it'll find that `b` is in+  scope (as a result of tcSkolemiseCompleteSig) which is a bit strange.  But+  it'll then unify the kinds `Type ~ b`, which will fail as it should.++*     f :: Int -> forall (a::Type) (b::a). blah+      f x  @p = rhs+  `matchExpectedFunTys` does shallow skolemisation eagerly, so we'll skolemise the+  forall a b.  Then `tcMatchPats` will bind [p :-> a_sk], and discard `b_sk`.+  Discarding the `b_sk` means that+      f x @p = \ @q -> blah+  or  f x @p = let .. in \ @q -> blah+  will both be rejected: this is Plan B2: skolemise at the "=".++* Suppose DeepSubsumption is on+    f :: forall a. a -> forall b. b -> b -> forall z. z+    f @p x @q y = rhs+  The `tcSkolemiseCompleteSig` uses shallow skolemisation, so it only skolemises+  and brings into scope [a :-> a_sk]. Then `matchExpectedFunTys` skolemises the+  forall b, because it needs to expose two value arguments.  Finally+  `matchExpectedFunTys` concludes with deeply skolemising the remaining type.++  So we end up with `[p :-> a_sk, q :-> b_sk]`.  Notice that we must not+  deeply-skolemise /first/ or we'd get the tyvars [a_sk, b_sk, c_sk] which would+  not line up with the patterns [@p, x, @q, y]+-}++tcSkolemiseGeneral+  :: DeepSubsumptionFlag+  -> UserTypeCtxt+  -> TcType -> TcType   -- top_ty and expected_ty+        -- Here, top_ty      is the type we started to skolemise; used only in SigSkol+        -- -     expected_ty is the type we are actually skolemising+        -- matchExpectedFunTys walks down the type, skolemising as it goes,+        -- keeping the same top_ty, but successively smaller expected_tys+  -> ([(Name, TcInvisTVBinder)] -> TcType -> TcM result)+  -> TcM (HsWrapper, result)+tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside+  | isRhoTyDS ds_flag expected_ty+    -- Fast path for a very very common case: no skolemisation to do+    -- But still call checkConstraints in case we need an implication regardless+  = do { let sig_skol = SigSkol ctxt top_ty []+       ; (ev_binds, result) <- checkConstraints sig_skol [] [] $+                               thing_inside [] expected_ty+       ; return (mkWpLet ev_binds, result) }++  | otherwise+  = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]+         --           in GHC.Tc.Utils.TcType+       ; rec { (wrap, tv_prs, given, rho_ty) <- case ds_flag of+                    Deep    -> deeplySkolemise skol_info expected_ty+                    Shallow -> topSkolemise skol_info expected_ty+             ; let sig_skol = SigSkol ctxt top_ty (map (fmap binderVar) tv_prs)+             ; skol_info <- mkSkolemInfo sig_skol }++       ; let skol_tvs = map (binderVar . snd) tv_prs+       ; traceTc "tcSkolemiseGeneral" (pprUserTypeCtxt ctxt <+> ppr skol_tvs <+> ppr given)+       ; (ev_binds, result) <- checkConstraints sig_skol skol_tvs given $+                               thing_inside tv_prs rho_ty++       ; return (wrap <.> mkWpLet ev_binds, result) }+         -- The ev_binds returned by checkConstraints is very+         -- often empty, in which case mkWpLet is a no-op++tcSkolemiseCompleteSig :: TcCompleteSig+                       -> ([ExpPatType] -> TcRhoType -> TcM result)+                       -> TcM (HsWrapper, result)+-- ^ The wrapper has type: spec_ty ~> expected_ty+-- See Note [Skolemisation] for the differences between+-- tcSkolemiseCompleteSig and tcTopSkolemise++tcSkolemiseCompleteSig (CSig { sig_bndr = poly_id, sig_ctxt = ctxt, sig_loc = loc })+                       thing_inside+  = do { cur_loc <- getSrcSpanM+       ; let poly_ty = idType poly_id+       ; setSrcSpan loc $   -- Sets the location for the implication constraint+         tcSkolemiseGeneral Shallow ctxt poly_ty poly_ty $ \tv_prs rho_ty ->+         setSrcSpan cur_loc $ -- Revert to the original location+         tcExtendNameTyVarEnv (map (fmap binderVar) tv_prs) $+         thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty }++tcSkolemiseExpectedType :: TcSigmaType+                        -> ([ExpPatType] -> TcRhoType -> TcM result)+                        -> TcM (HsWrapper, result)+-- Just like tcSkolemiseCompleteSig, except that we don't have a user-written+-- type signature, we only have a type comimg from the context.+-- Eg. f :: (forall a. blah) -> blah+--     In the call (f e) we will call tcSkolemiseExpectedType on (forall a.blah)+--     before typececking `e`+tcSkolemiseExpectedType exp_ty thing_inside+  = tcSkolemiseGeneral Shallow GenSigCtxt exp_ty exp_ty $ \tv_prs rho_ty ->+    thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty++tcSkolemise :: DeepSubsumptionFlag -> UserTypeCtxt -> TcSigmaType+            -> (TcRhoType -> TcM result)+            -> TcM (HsWrapper, result)+tcSkolemise ds_flag ctxt expected_ty thing_inside+  = tcSkolemiseGeneral ds_flag ctxt expected_ty expected_ty $ \_ rho_ty ->+    thing_inside rho_ty++checkConstraints :: SkolemInfoAnon+                 -> [TcTyVar]           -- Skolems+                 -> [EvVar]             -- Given+                 -> TcM result+                 -> TcM (TcEvBinds, result)+-- checkConstraints is careful to build an implication even if+-- `skol_tvs` and `given` are both empty, under certain circumstances+-- See Note [When to build an implication]+checkConstraints skol_info skol_tvs given thing_inside+  = do { implication_needed <- implicationNeeded skol_info skol_tvs given++       ; if implication_needed+         then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside+                 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted+                 ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)+                 ; emitImplications implics+                 ; return (ev_binds, result) }++         else -- Fast path.  We check every function argument with tcCheckPolyExpr,+              -- which uses tcTopSkolemise and hence checkConstraints.+              -- So this fast path is well-exercised+              do { res <- thing_inside+                 ; return (emptyTcEvBinds, res) } }++checkTvConstraints :: SkolemInfo+                   -> [TcTyVar]          -- Skolem tyvars+                   -> TcM result+                   -> TcM result++checkTvConstraints skol_info skol_tvs thing_inside+  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside+       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted+       ; return result }++emitResidualTvConstraint :: SkolemInfo -> [TcTyVar]+                         -> TcLevel -> WantedConstraints -> TcM ()+emitResidualTvConstraint skol_info skol_tvs tclvl wanted+  | not (isEmptyWC wanted) ||+    checkTelescopeSkol skol_info_anon+  = -- checkTelescopeSkol: in this case, /always/ emit this implication+    -- even if 'wanted' is empty. We need the implication so that we check+    -- for a bad telescope. See Note [Skolem escape and forall-types] in+    -- GHC.Tc.Gen.HsType+    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted+       ; emitImplication implic }++  | otherwise  -- Empty 'wanted', emit nothing+  = return ()+  where+     skol_info_anon = getSkolemInfo skol_info++buildTvImplication :: SkolemInfoAnon -> [TcTyVar]+                   -> TcLevel -> WantedConstraints -> TcM Implication+buildTvImplication skol_info skol_tvs tclvl wanted+  = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $+    do { ev_binds <- newNoTcEvBinds  -- Used for equalities only, so all the constraints+                                     -- are solved by filling in coercion holes, not+                                     -- by creating a value-level evidence binding+       ; implic   <- newImplication++       ; let implic' = implic { ic_tclvl     = tclvl+                              , ic_skols     = skol_tvs+                              , ic_given_eqs = NoGivenEqs+                              , ic_wanted    = wanted+                              , ic_binds     = ev_binds+                              , ic_info      = skol_info }++       ; checkImplicationInvariants implic'+       ; return implic' }++implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool+-- See Note [When to build an implication]+implicationNeeded skol_info skol_tvs given+  | null skol_tvs+  , null given+  , not (alwaysBuildImplication skol_info)+  = -- Empty skolems and givens+    do { tc_lvl <- getTcLevel+       ; if not (isTopTcLevel tc_lvl)  -- No implication needed if we are+         then return False             -- already inside an implication+         else+    do { dflags <- getDynFlags       -- If any deferral can happen,+                                     -- we must build an implication+       ; return (gopt Opt_DeferTypeErrors dflags ||+                 gopt Opt_DeferTypedHoles dflags ||+                 gopt Opt_DeferOutOfScopeVariables dflags) } }++  | otherwise     -- Non-empty skolems or givens+  = return True   -- Definitely need an implication++alwaysBuildImplication :: SkolemInfoAnon -> Bool+-- See Note [When to build an implication]+alwaysBuildImplication _ = False++{-  Commmented out for now while I figure out about error messages.+    See #14185++Caution: we get some duplication of errors if we build more implications.+Because we get one error for each function RHS, even if it's for+the same class constraint.++alwaysBuildImplication (SigSkol ctxt _ _)+  = case ctxt of+      FunSigCtxt {} -> True  -- RHS of a binding with a signature+      _             -> False+alwaysBuildImplication (RuleSkol {})      = True+alwaysBuildImplication (InstSkol {})      = True+alwaysBuildImplication (FamInstSkol {})   = True+alwaysBuildImplication _                  = False+-}++buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar]+                   -> [EvVar] -> WantedConstraints+                   -> TcM (Bag Implication, TcEvBinds)+buildImplicationFor tclvl skol_info skol_tvs given wanted+  | isEmptyWC wanted && null given+             -- Optimisation : if there are no wanteds, and no givens+             -- don't generate an implication at all.+             -- Reason for the (null given): we don't want to lose+             -- the "inaccessible alternative" error check+  = return (emptyBag, emptyTcEvBinds)++  | otherwise+  = 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,+      -- because TyVarTvs will always remain tyvars, even after unification.+    do { ev_binds_var <- newTcEvBinds+       ; implic <- newImplication+       ; let implic' = implic { ic_tclvl  = tclvl+                              , ic_skols  = skol_tvs+                              , ic_given  = given+                              , ic_wanted = wanted+                              , ic_binds  = ev_binds_var+                              , ic_info   = skol_info }+       ; checkImplicationInvariants implic'++       ; return (unitBag implic', TcEvBinds ev_binds_var) }++{- Note [When to build an implication]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have some 'skolems' and some 'givens', and we are+considering whether to wrap the constraints in their scope into an+implication.  We must /always/ do so if either 'skolems' or 'givens' are+non-empty.  But what if both are empty?  You might think we could+always drop the implication.  Other things being equal, the fewer+implications the better.  Less clutter and overhead.  But we must+take care:++* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,+  we'll make a /term-level/ evidence binding for 'g = error "blah"'.+  We must have an EvBindsVar those bindings!, otherwise they end up as+  top-level unlifted bindings, which are verboten. This only matters+  at top level, so we check for that+  See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors.+  cf #14149 for an example of what goes wrong.++* This is /necessary/ for top level but may be /desirable/ even for+  nested bindings, because if the deferred coercion is bound too far+  out it will be reported even if that thunk (say) is not evaluated.++* If you have+     f :: Int;  f = f_blah+     g :: Bool; g = g_blah+  If we don't build an implication for f or g (no tyvars, no givens),+  the constraints for f_blah and g_blah are solved together.  And that+  can yield /very/ confusing error messages, because we can get+      [W] C Int b1    -- from f_blah+      [W] C Int b2    -- from g_blan+  and fundeps can yield [W] b1 ~ b2, even though the two functions have+  literally nothing to do with each other.  #14185 is an example.+  Building an implication keeps them separate.++Note [Herald for matchExpectedFunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'herald' always looks like:+   "The equation(s) for 'f' have"+   "The abstraction (\x.e) takes"+   "The section (+ x) expects"+   "The function 'f' is applied to"++This is used to construct a message of form++   The abstraction `\Just 1 -> ...' takes two arguments+   but its type `Maybe a -> a' has only one++   The equation(s) for `f' have two arguments+   but its type `Maybe a -> a' has only one++   The section `(f 3)' requires 'f' to take two arguments+   but its type `Int -> Int' has only one++   The function 'f' is applied to two arguments+   but its type `Int -> Int' has only one++When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the+picture, we have a choice in deciding whether to count the type applications as+proper arguments:++   The function 'f' is applied to one visible type argument+     and two value arguments+   but its type `forall a. a -> a` has only one visible type argument+     and one value argument++Or whether to include the type applications as part of the herald itself:++   The expression 'f @Int' is applied to two arguments+   but its type `Int -> Int` has only one++The latter is easier to implement and is arguably easier to understand, so we+choose to implement that option.++Note [matchExpectedFunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~+matchExpectedFunTys checks that a sigma has the form+of an n-ary function.  It passes the decomposed type to the+thing_inside, and returns a wrapper to coerce between the two types++It's used wherever a language construct must have a functional type,+namely:+        A lambda expression+        A function definition+     An operator section++This function must be written CPS'd because it needs to fill in the+ExpTypes produced for arguments before it can fill in the ExpType+passed in.++Note [Return arguments with a fixed RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions++  - matchExpectedFunTys,+  - matchActualFunTy,+  - matchActualFunTys,++peel off argument types, as explained in Note [matchExpectedFunTys].+It's important that these functions return argument types that have+a fixed runtime representation, otherwise we would be in violation+of the representation-polymorphism invariants of+Note [Representation polymorphism invariants] in GHC.Core.++This is why all these functions have an additional invariant,+that the argument types they return all have a syntactically fixed RuntimeRep,+in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.++Example:++  Suppose we have++    type F :: Type -> RuntimeRep+    type family F a where { F Int = LiftedRep }++    type Dual :: Type -> Type+    type family Dual a where+      Dual a = a -> ()++    f :: forall (a :: TYPE (F Int)). Dual a+    f = \ x -> ()++  The body of `f` is a lambda abstraction, so we must be able to split off+  one argument type from its type. This is handled by `matchExpectedFunTys`+  (see 'GHC.Tc.Gen.Match.tcLambdaMatches'). We end up with desugared Core that+  looks like this:++    f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0]))+    f = \ @(a :: TYPE (F Int)) ->+          (\ (x :: (a |> (TYPE F[0]))) -> ())+          `cast`+          (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>)))++  Two important transformations took place:++    1. We inserted casts around the argument type to ensure that it has+       a fixed runtime representation, as required by invariant (I1) from+       Note [Representation polymorphism invariants] in GHC.Core.+    2. We inserted a cast around the whole lambda to make everything line up+       with the type signature.+-}++-- | Use this function to split off arguments types when you have an+-- \"expected\" type.+--+-- This function skolemises at each polytype.+--+-- Invariant: this function only applies the provided function+-- to a list of argument types which all have a syntactically fixed RuntimeRep+-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+-- See Note [Return arguments with a fixed RuntimeRep].+matchExpectedFunTys :: forall a.+                       ExpectedFunTyOrigin  -- See Note [Herald for matchExpectedFunTys]+                    -> UserTypeCtxt+                    -> VisArity+                    -> ExpSigmaType+                    -> ([ExpPatType] -> ExpRhoType -> TcM a)+                    -> TcM (HsWrapper, a)+-- If    matchExpectedFunTys n ty = (wrap, _)+-- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,+--   where [t1, ..., tn], ty_r are passed to the thing_inside+--+-- Unconditionally concludes by skolemising any trailing invisible+-- binders and, if DeepSubsumption is on, it does so deeply.+--+-- Postcondition:+--   If exp_ty is Check {}, then [ExpPatType] and ExpRhoType results are all Check{}+--   If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{}+matchExpectedFunTys herald _ctxt arity (Infer inf_res) thing_inside+  = do { arg_tys <- mapM (new_infer_arg_ty herald) [1 .. arity]+       ; res_ty  <- newInferExpType (ir_inst inf_res)+       ; result  <- thing_inside (map ExpFunPatTy arg_tys) res_ty+       ; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys+       ; res_ty  <- readExpType res_ty+         -- Remarks:+         --  1. use tcMkScaledFunTys rather than mkScaledFunTys, as we might+         --     have res_ty :: kappa[tau] for a meta ty-var kappa, in which case+         --     mkScaledFunTys would crash. See #26277.+         --  2. tcMkScaledFunTys arg_tys res_ty does not contain any foralls+         --     (even nested ones), so no need to instantiate.+       ; co <- fillInferResultNoInst (tcMkScaledFunTys arg_tys res_ty) inf_res+       ; return (mkWpCastN co, result) }++matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside+  = check arity [] top_ty+  where+    check :: VisArity -> [ExpPatType] -> TcSigmaType -> TcM (HsWrapper, a)+    -- `check` is called only in the Check{} case+    -- It collects rev_pat_tys in reversed order+    -- n_req is the number of /visible/ arguments still needed++    ----------------------------+    -- Skolemise quantifiers, both visible (up to n_req) and invisible+    -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App+    check n_req rev_pat_tys ty+      | isSigmaTy ty                     -- An invisible quantifier at the top+        || (n_req > 0 && isForAllTy ty)  -- A visible quantifier at top, and we need it+      = do { rec { (n_req', wrap_gen, tv_nms, bndrs, given, inner_ty) <- skolemiseRequired skol_info n_req ty+                 ; let sig_skol = SigSkol ctx top_ty (tv_nms `zip` skol_tvs)+                       skol_tvs = binderVars bndrs+                 ; skol_info <- mkSkolemInfo sig_skol }+             -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]+             --           in GHC.Tc.Utils.TcType+           ; (ev_binds, (wrap_res, result))+                  <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $+                     check n_req'+                           (reverse (map ExpForAllPatTy bndrs) ++ rev_pat_tys)+                           inner_ty+           ; assertPpr (not (null bndrs && null given)) (ppr ty) $+                       -- The guard ensures that we made some progress+             return (wrap_gen <.> mkWpLet ev_binds <.> wrap_res, result) }++    ----------------------------+    -- Base case: (n_req == 0): no more args+    --    The earlier skolemisation ensurs that rho_ty has no top-level invisible quantifiers+    --    If there is deep subsumption, do deep skolemisation now+    check n_req rev_pat_tys rho_ty+      | n_req == 0+      = do { let pat_tys = reverse rev_pat_tys+           ; ds_flag <- getDeepSubsumptionFlag+           ; case ds_flag of+               Shallow -> do { res <- thing_inside pat_tys (mkCheckExpType rho_ty)+                             ; return (idHsWrapper, res) }+               Deep    -> tcSkolemiseGeneral Deep ctx top_ty rho_ty $ \_ rho_ty ->+                          -- "_" drop the /deeply/-skolemise binders+                          -- They do not line up with binders in the Match+                          thing_inside pat_tys (mkCheckExpType rho_ty) }++    ----------------------------+    -- Function types+    check n_req rev_pat_tys (FunTy { ft_af = af, ft_mult = mult+                                   , ft_arg = arg_ty, ft_res = res_ty })+      = assert (isVisibleFunArg af) $+        do { let arg_pos = arity - n_req + 1   -- 1 for the first argument etc+           ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty+           ; (wrap_res, result) <- check (n_req - 1)+                                         (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys)+                                         res_ty+           ; let wrap_arg = mkWpCastN arg_co+                 fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty+           ; return (fun_wrap, result) }++    ----------------------------+    -- Type variables+    check n_req rev_pat_tys ty@(TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty' -> check n_req rev_pat_tys ty'+               Flexi        -> defer n_req rev_pat_tys ty }++    ----------------------------+    -- NOW do coreView.  We didn't do it before, so that we do not unnecessarily+    -- unwrap a synonym in the returned rho_ty+    check n_req rev_pat_tys ty+      | Just ty' <- coreView ty = check n_req rev_pat_tys ty'++       -- In all other cases we bale out into ordinary unification+       -- However unlike the meta-tyvar case, we are sure that the+       -- number of arguments doesn't match arity of the original+       -- type, so we can add a bit more context to the error message+       -- (cf #7869).+       --+       -- It is not always an error, because specialized type may have+       -- different arity, for example:+       --+       -- > f1 = f2 'a'+       -- > f2 :: Monad m => m Bool+       -- > f2 = undefined+       --+       -- But in that case we add specialized type into error context+       -- anyway, because it may be useful. See also #9605.+    check n_req rev_pat_tys res_ty+      = addErrCtxtM (mkFunTysMsg herald (arity, top_ty))  $+        defer n_req rev_pat_tys res_ty++    ------------+    defer :: VisArity -> [ExpPatType] -> TcRhoType -> TcM (HsWrapper, a)+    defer n_req rev_pat_tys fun_ty+      = do { more_arg_tys <- mapM (new_check_arg_ty herald) [arity - n_req + 1 .. arity]+           ; let all_pats = reverse rev_pat_tys ++ map mkCheckExpFunPatTy more_arg_tys+           ; res_ty <- newOpenFlexiTyVarTy+           ; result <- thing_inside all_pats (mkCheckExpType res_ty)++           ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty+           ; return (mkWpCastN co, result) }++new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR)+new_infer_arg_ty herald arg_pos -- position for error messages only+  = do { mult     <- newFlexiTyVarTy multiplicityTy+       ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos)+       ; return (mkScaled mult inf_hole) }++new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType)+new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg+  = do { mult   <- newFlexiTyVarTy multiplicityTy+       ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos)+       ; return (mkScaled mult arg_ty) }++mkFunTysMsg :: ExpectedFunTyOrigin+            -> (VisArity, TcType)+            -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)+-- See Note [Reporting application arity errors]+mkFunTysMsg herald (n_vis_args_in_call, fun_ty) env+  = do { (env', fun_ty) <- zonkTidyTcType env fun_ty++       ; let (pi_ty_bndrs, _) = splitPiTys fun_ty+             n_fun_args = count isVisiblePiTyBinder pi_ty_bndrs++       ; return (env', FunTysCtxt herald fun_ty n_vis_args_in_call n_fun_args) }+++{- Note [Reporting application arity errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider      f :: Int -> Int -> Int+and the call  foo = f 3 4 5+We'd like to get an error like:++    • Couldn't match expected type ‘t0 -> t’ with actual type ‘Int’+    • The function ‘f’ is applied to three visible arguments,           -- What are "visible" arguments?+        but its type ‘Int -> Int -> Int’ has only two                   -- See Note [Visibility and arity] in GHC.Types.Basic++That is what `mkFunTysMsg` tries to do.  But what is the "type of the function".+Most obviously, we can report its full, polymorphic type; that is simple and+explicable.  But sometimes a bit odd.  Consider+    f :: Bool -> t Int Int+    foo = f True 5 10+We get this error:+    • Couldn't match type ‘Int’ with ‘t0 -> t’+      Expected: Int -> t0 -> t+        Actual: Int -> Int+    • The function ‘f’ is applied to three visible arguments,+        but its type ‘Bool -> t Int Int’ has only one++That's not /quite/ right beause we can instantiate `t` to an arrow and get+two arrows (but not three!).  With that in mind, one could consider reporting+the /instantiated/ type, and GHC used to do so.  But it's more work, and in+some ways more confusing, especially when nested quantifiers are concerned, e.g.+    f :: Bool -> forall t. t Int Int++So we just keep it simple and report the original function type.+++************************************************************************+*                                                                      *+                    Other matchExpected functions+*                                                                      *+********************************************************************* -}++matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)+-- Special case for lists+matchExpectedListTy exp_ty+ = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty+      ; return (co, elt_ty) }++---------------------+matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *+                      -> TcRhoType            -- orig_ty+                      -> TcM (TcCoercionN,    -- T k1 k2 k3 a b c ~N orig_ty+                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c++-- It's used for wired-in tycons, so we call checkWiredInTyCon+-- Precondition: never called with FunTyCon+-- Precondition: input type :: *+-- Postcondition: (T k1 k2 k3 a b c) is well-kinded++matchExpectedTyConApp tc orig_ty+  = assertPpr (isAlgTyCon tc) (ppr tc) $+    go orig_ty+  where+    go ty+       | Just ty' <- coreView ty+       = go ty'++    go ty@(TyConApp tycon args)+       | tc == tycon  -- Common case+       = return (mkNomReflCo ty, args)++    go (TyVarTy tv)+       | isMetaTyVar tv+       = do { cts <- readMetaTyVar tv+            ; case cts of+                Indirect ty -> go ty+                Flexi       -> defer }++    go _ = defer++    -- If the common case does not occur, instantiate a template+    -- T k1 .. kn t1 .. tm, and unify with the original type+    -- Doing it this way ensures that the types we return are+    -- kind-compatible with T.  For example, suppose we have+    --       matchExpectedTyConApp T (f Maybe)+    -- where data T a = MkT a+    -- Then we don't want to instantiate T's data constructors with+    --    (a::*) ~ Maybe+    -- because that'll make types that are utterly ill-kinded.+    -- This happened in #7368+    defer+      = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)+           ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)+           ; let args = mkTyVarTys arg_tvs+                 tc_template = mkTyConApp tc args+           ; co <- unifyType Nothing tc_template orig_ty+           ; return (co, args) }++----------------------+matchExpectedAppTy :: TcRhoType                         -- orig_ty+                   -> TcM (TcCoercion,                   -- m a ~N orig_ty+                           (TcSigmaType, TcSigmaType))  -- Returns m, a+-- If the incoming type is a mutable type variable of kind k, then+-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.++matchExpectedAppTy orig_ty+  = go orig_ty+  where+    go ty+      | Just ty' <- coreView ty = go ty'++      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty+      = return (mkNomReflCo orig_ty, (fun_ty, arg_ty))++    go (TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty -> go ty+               Flexi       -> defer }++    go _ = defer++    -- Defer splitting by generating an equality constraint+    defer+      = do { ty1 <- newFlexiTyVarTy kind1+           ; ty2 <- newFlexiTyVarTy kind2+           ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty+           ; return (co, (ty1, ty2)) }++    orig_kind = typeKind orig_ty+    kind1 = mkVisFunTyMany liftedTypeKind orig_kind+    kind2 = liftedTypeKind    -- m :: * -> k+                              -- arg type :: *++{- **********************************************************************+*+                      fillInferResult+*+********************************************************************** -}++-- | Fill an 'InferResult' with the given type.+--+-- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@,+-- where @t2@ is the type stored in the 'ir_ref' field of @infer_res@.+--+-- This function enforces the following invariants:+--+--  - Level invariant.+--    The stored type @t2@ is at the same level as given by the+--    'ir_lvl' field.+--  - FRR invariant.+--    Whenever the 'ir_frr' field is `IFRR_Check`, @t2@ is guaranteed+--    to have a syntactically fixed RuntimeRep, in the sense of+--    Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+fillInferResultNoInst :: TcType -> InferResult -> TcM TcCoercionN+fillInferResultNoInst act_res_ty (IR { ir_uniq = u+                                     , ir_lvl  = res_lvl+                                     , ir_frr  = mb_frr+                                     , ir_ref  = ref })+  = do { mb_exp_res_ty <- readTcRef ref+       ; case mb_exp_res_ty of+            Just exp_res_ty+               -- We progressively refine the type stored in 'ref',+               -- for example when inferring types across multiple equations.+               --+               -- Example:+               --+               --  \ x -> case y of { True -> x ; False -> 3 :: Int }+               --+               -- When inferring the return type of this function, we will create+               -- an 'Infer' 'ExpType', which will first be filled by the type of 'x'+               -- after typechecking the first equation, and then filled again with+               -- the type 'Int', at which point we want to ensure that we unify+               -- the type of 'x' with 'Int'. This is what is happening below when+               -- we are "joining" several inferred 'ExpType's.+               -> do { traceTc "Joining inferred ExpType" $+                       ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty+                     ; cur_lvl <- getTcLevel+                     ; unless (cur_lvl `sameDepthAs` res_lvl) $+                       ensureMonoType act_res_ty -- See (FIR1)+                     ; unifyType Nothing act_res_ty exp_res_ty }+            Nothing+               -> do { traceTc "Filling inferred ExpType" $+                       ppr u <+> text ":=" <+> ppr act_res_ty++                     -- Enforce the level invariant: ensure the TcLevel of+                     -- the type we are writing to 'ref' matches 'ir_lvl'.+                     ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty++                     -- Enforce the FRR invariant: ensure the type has a syntactically+                     -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing').+                     ; (frr_co, act_res_ty) <-+                         case mb_frr of+                           IFRR_Any            -> return (mkNomReflCo act_res_ty, act_res_ty)+                           IFRR_Check frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty++                     -- Compose the two coercions.+                     ; let final_co = prom_co `mkTransCo` frr_co++                     ; writeTcRef ref (Just act_res_ty)++                     ; return final_co } }++fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper+-- See Note [Instantiation of InferResult]+fillInferResult ct_orig res_ty ires@(IR { ir_inst = iif })+  = case iif of+       IIF_Sigma      -> do { co <- fillInferResultNoInst res_ty ires+                            ; return (mkWpCastN co) }+       IIF_ShallowRho -> do { (wrap, res_ty') <- topInstantiate ct_orig res_ty+                            ; co <- fillInferResultNoInst res_ty' ires+                            ; return (mkWpCastN co <.> wrap) }+       IIF_DeepRho     -> do { (wrap, res_ty') <- dsInstantiate ct_orig res_ty+                             ; co <- fillInferResultNoInst res_ty' ires+                             ; return (mkWpCastN co <.> wrap) }++{- Note [fillInferResult]+~~~~~~~~~~~~~~~~~~~~~~~~~+When inferring, we use fillInferResult to "fill in" the hole in InferResult+   data InferResult = IR { ir_uniq :: Unique+                         , ir_lvl  :: TcLevel+                         , ir_ref  :: IORef (Maybe TcType) }++There are two things to worry about:++1. What if it is under a GADT or existential pattern match?+   - GADTs: a unification variable (and Infer's hole is similar) is untouchable+   - Existentials: be careful about skolem-escape++2. What if it is filled in more than once?  E.g. multiple branches of a case+     case e of+        T1 -> e1+        T2 -> e2++Our typing rules are:++* The RHS of a existential or GADT alternative must always be a+  monotype, regardless of the number of alternatives.++* Multiple non-existential/GADT branches can have (the same)+  higher rank type (#18412).  E.g. this is OK:+      case e of+        True  -> hr+        False -> hr+  where hr:: (forall a. a->a) -> Int+  c.f. Section 7.1 of "Practical type inference for arbitrary-rank types"+       We use choice (2) in that Section.+       (GHC 8.10 and earlier used choice (1).)++  But note that+      case e of+        True  -> hr+        False -> \x -> hr x+  will fail, because we still /infer/ both branches, so the \x will get+  a (monotype) unification variable, which will fail to unify with+  (forall a. a->a)++For (1) we can detect the GADT/existential situation by seeing that+the current TcLevel is greater than that stored in ir_lvl of the Infer+ExpType.  We bump the level whenever we go past a GADT/existential match.++Then, before filling the hole use promoteTcType to promote the type+to the outer ir_lvl.  promoteTcType does this+  - create a fresh unification variable alpha at level ir_lvl+  - emits an equality alpha[ir_lvl] ~ ty+  - fills the hole with alpha+That forces the type to be a monotype (since unification variables can+only unify with monotypes); and catches skolem-escapes because the+alpha is untouchable until the equality floats out.++For (2), we simply look to see if the hole is filled already.+  - if not, we promote (as above) and fill the hole+  - if it is filled, we simply unify with the type that is+    already there++(FIR1) There is one wrinkle.  Suppose we have+             case e of+                T1 -> e1 :: (forall a. a->a) -> Int+                G2 -> e2+    where T1 is not GADT or existential, but G2 is a GADT.  Then suppose the+    T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.+    But now the G2 alternative must not *just* unify with that else we'd risk+    allowing through (e2 :: (forall a. a->a) -> Int).  If we'd checked G2 first+    we'd have filled the hole with a unification variable, which enforces a+    monotype.++    So if we check G2 second, we still want to emit a constraint that restricts+    the RHS to be a monotype. This is done by ensureMonoType, and it works+    by simply generating a constraint (alpha ~ ty), where alpha is a fresh+unification variable.  We discard the evidence.++Note [Instantiation of InferResult]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typechecking expressions (not types, not patterns), we always almost+always instantiate before filling in `InferResult`, so that the result is a+TcRhoType. This behaviour is controlled by the `ir_inst :: InferInstFlag`+field of `InferResult`.++If we do instantiate (ir_inst = IIF_DeepRho), and DeepSubsumption is enabled,+we instantiate deeply. See `tcInferResult`.++Usually this field is `IIF_DeepRho` meaning "return a (possibly deep) rho-type".+Why is this the common case?  See #17173 for discussion.  Here are some examples+of why:++1. Consider+    f x = (*)+   We want to instantiate the type of (*) before returning, else we+   will infer the type+     f :: forall {a}. a -> forall b. Num b => b -> b -> b+   This is surely confusing for users.++   And worse, the monomorphism restriction won't work properly. The MR is+   dealt with in simplifyInfer, and simplifyInfer has no way of+   instantiating. This could perhaps be worked around, but it may be+   hard to know even when instantiation should happen.++2. Another reason.  Consider+       f :: (?x :: Int) => a -> a+       g y = let ?x = 3::Int in f+   Here want to instantiate f's type so that the ?x::Int constraint+  gets discharged by the enclosing implicit-parameter binding.++3. Suppose one defines plus = (+). If we instantiate lazily, we will+   infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism+   restriction compels us to infer+      plus :: Integer -> Integer -> Integer+   (or similar monotype). Indeed, the only way to know whether to apply+   the monomorphism restriction at all is to instantiate++HOWEVER, not always! Here are places where we want `IIF_Sigma` meaning+"return a sigma-type":++* IIF_Sigma: In GHC.Tc.Module.tcRnExpr, which implements GHCi's :type+  command, we want to return a completely uninstantiated type.+  See Note [Implementing :type] in GHC.Tc.Module.++* IIF_Sigma: In types we can't lambda-abstract, so we must be careful not to instantiate+  at all. See calls to `runInferHsType`++* IIF_Sigma: in patterns we don't want to instantiate at all. See the use of+  `runInferSigmaFRR` in GHC.Tc.Gen.Pat++* IIF_ShallowRho: in the expression part of a view pattern, we must top-instantiate+  but /not/ deeply instantiate (#26331). See Note [View patterns and polymorphism]+  in GHC.Tc.Gen.Pat.  This the only place we use IIF_ShallowRho.++Why do we want to deeply instantiate, ever?  Why isn't top-instantiation enough?+Answer: to accept the following program (T26225b) with -XDeepSubsumption, we+need to deeply instantiate when inferring in checkResultTy:++  f :: Int -> (forall a. a->a)+  g :: Int -> Bool -> Bool++  test b =+    case b of+      True  -> f+      False -> g++If we don't deeply instantiate in the branches of the case expression, we will+try to unify the type of 'f' with that of 'g', which fails. If we instead+deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha'+which then successfully unifies with the type of 'g' when we come to fill the+'InferResult' hole a second time for the second case branch.+-}++{-+************************************************************************+*                                                                      *+                Subsumption checking+*                                                                      *+************************************************************************++Note [Subsumption checking: tcSubType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All the tcSubType calls have the form+                tcSubType actual_ty expected_ty+which checks+                actual_ty <= expected_ty++That is, that a value of type actual_ty is acceptable in+a place expecting a value of type expected_ty.  I.e. that++    actual ty   is more polymorphic than   expected_ty++It returns a wrapper function+        co_fn :: actual_ty ~ expected_ty+which takes an HsExpr of type actual_ty into one of type+expected_ty.++Note [Ambiguity check and deep subsumption]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: (forall b. Eq b => a -> a) -> Int++Does `f` have an ambiguous type?   The ambiguity check usually checks+that this definition of f' would typecheck, where f' has the exact same+type as f:+   f' :: (forall b. Eq b => a -> a) -> Intp+   f' = f++This will be /rejected/ with DeepSubsumption but /accepted/ with+ShallowSubsumption.  On the other hand, this eta-expanded version f''+would be rejected both ways:+   f'' :: (forall b. Eq b => a -> a) -> Intp+   f'' x = f x++This is squishy in the same way as other examples in GHC.Tc.Validity+Note [The squishiness of the ambiguity check]++The situation in June 2022.  Since we have SimpleSubsumption at the moment,+we don't want introduce new breakage if you add -XDeepSubsumption, by+rejecting types as ambiguous that weren't ambiguous before.  So, as a+holding decision, we /always/ use SimpleSubsumption for the ambiguity check+(erring on the side accepting more programs). Hence tcSubTypeAmbiguity.+-}++++-----------------+-- tcWrapResult needs both un-type-checked (for origins and error messages)+-- and type-checked (for wrapping) expressions+tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType+             -> TcM (HsExpr GhcTc)+tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr++tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType+               -> TcM (HsExpr GhcTc)+tcWrapResultO orig rn_expr expr actual_ty res_ty+  = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty+                                      , text "Expected:" <+> ppr res_ty ])+       ; wrap <- tcSubType orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty+       ; return (mkHsWrap wrap expr) }++-- | A version of 'tcWrapResult' to use when the actual type is a+-- rho-type, so nothing to instantiate; just go straight to unify.+-- It means we don't need to pass in a CtOrigin.+tcWrapResultMono :: HasDebugCallStack+                 => HsExpr GhcRn -> HsExpr GhcTc+                 -> TcRhoType   -- ^ Actual; a rho-type, not a sigma-type+                 -> ExpRhoType  -- ^ Expected+                 -> TcM (HsExpr GhcTc)+tcWrapResultMono rn_expr expr act_ty res_ty+  = do { co <- tcSubTypeMono rn_expr act_ty res_ty+       ; return (mkHsWrapCo co expr) }++-- | A version of 'tcSubType' to use when the actual type is a rho-type,+-- so that no instantiation is needed.+tcSubTypeMono :: HasDebugCallStack+              => HsExpr GhcRn+              -> TcRhoType   -- ^ Actual; a rho-type, not a sigma-type+              -> ExpRhoType  -- ^ Expected+              -> TcM TcCoercionN+tcSubTypeMono rn_expr act_ty exp_ty+  = assertPpr (isDeepRhoTy act_ty)+      (vcat [ text "Actual type is not a (deep) rho-type."+            , text "act_ty:" <+> ppr act_ty+            , text "rn_expr:" <+> ppr rn_expr]) $+    case exp_ty of+      Infer inf_res -> fillInferResultNoInst act_ty inf_res+      Check exp_ty  -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty++------------------------+tcSubTypePat :: CtOrigin -> UserTypeCtxt+            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper+-- Used in patterns; polarity is backwards compared+--   to tcSubType+-- If wrap = tc_sub_type_et t1 t2+--    => wrap :: t1 ~> t2+tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected+  = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected++tcSubTypePat _ _ (Infer inf_res) ty_expected+  = do { co <- fillInferResultNoInst ty_expected inf_res+               -- In patterns we do not instantatiate++       ; return (mkWpCastN (mkSymCo co)) }++---------------++-- | A subtype check that performs deep subsumption.+-- See also 'tcSubTypeMono', for when no instantiation is required.+tcSubTypeDS :: HsExpr GhcRn+            -> TcRhoType   -- Actual type -- a rho-type not a sigma-type+            -> TcRhoType   -- Expected type+                           -- DeepSubsumption <=> when checking, this type+                           --                     is deeply skolemised+            -> TcM HsWrapper+-- Only one call site, in GHC.Tc.Gen.App.tcApp+tcSubTypeDS rn_expr act_rho exp_rho+  = tc_sub_type_deep Top (unifyExprType rn_expr) orig GenSigCtxt act_rho exp_rho+  where+    orig = exprCtOrigin rn_expr++---------------++-- | Checks that the 'actual' type is more polymorphic than the 'expected' type.+tcSubType :: CtOrigin          -- ^ Used when instantiating+          -> UserTypeCtxt      -- ^ Used when skolemising+          -> Maybe TypedThing  -- ^ The expression that has type 'actual' (if known)+          -> TcSigmaType       -- ^ Actual type+          -> ExpRhoType        -- ^ Expected type+          -> TcM HsWrapper+tcSubType inst_orig ctxt m_thing ty_actual res_ty+  = case res_ty of+      Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt+                                       ty_actual ty_expected++      Infer inf_res -> fillInferResult inst_orig ty_actual inf_res++---------------+tcSubTypeSigma :: CtOrigin       -- where did the actual type arise / why are we+                                 -- doing this subtype check?+               -> UserTypeCtxt   -- where did the expected type arise?+               -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- External entry point, but no ExpTypes on either side+-- Checks that actual <= expected+-- Returns HsWrapper :: actual ~ expected+tcSubTypeSigma orig ctxt ty_actual ty_expected+  = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected++---------------+tcSubTypeAmbiguity :: UserTypeCtxt   -- Where did this type arise+                   -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- See Note [Ambiguity check and deep subsumption]+tcSubTypeAmbiguity ctxt ty_actual ty_expected+  = tc_sub_type_ds Top Shallow (unifyType Nothing)+                             (AmbiguityCheckOrigin ctxt)+                             ctxt ty_actual ty_expected++---------------+addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a+addSubTypeCtxt ty_actual ty_expected thing_inside+ | isRhoTy ty_actual        -- If there is no polymorphism involved, the+ , isRhoExpTy ty_expected   -- TypeEqOrigin stuff (added by the _NC functions)+ = thing_inside             -- gives enough context by itself+ | otherwise+ = addErrCtxtM mk_msg thing_inside+  where+    mk_msg tidy_env+      = do { (tidy_env, ty_actual)   <- zonkTidyTcType tidy_env ty_actual+           ; ty_expected             <- readExpType ty_expected+                   -- A worry: might not be filled if we're debugging. Ugh.+           ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected+           ; return (tidy_env, SubTypeCtxt ty_expected ty_actual) }+++---------------+tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN)  -- How to unify+            -> CtOrigin       -- Used when instantiating+            -> UserTypeCtxt   -- Used when skolemising+            -> TcSigmaType    -- Actual; a sigma-type+            -> TcSigmaType    -- Expected; also a sigma-type+            -> TcM HsWrapper+-- Checks that actual_ty is more polymorphic than expected_ty+-- If wrap = tc_sub_type t1 t2+--    => wrap :: t1 ~> t2+--+-- The "how to unify argument" is always a call to `uType TypeLevel orig`,+-- but with different ways of constructing the CtOrigin `orig` from+-- the argument types and context.++----------------------+tc_sub_type unify inst_orig ctxt ty_actual ty_expected+  = do { ds_flag <- getDeepSubsumptionFlag+       ; tc_sub_type_ds Top ds_flag unify inst_orig ctxt ty_actual ty_expected }++----------------------+tc_sub_type_ds :: Position p -- ^ position in the type (for error messages only)+               -> DeepSubsumptionFlag+               -> (TcType -> TcType -> TcM TcCoercionN)+               -> CtOrigin -> UserTypeCtxt -> TcSigmaType+               -> TcSigmaType -> TcM HsWrapper+-- tc_sub_type_ds is the main subsumption worker function+-- It takes an explicit DeepSubsumptionFlag+tc_sub_type_ds pos ds_flag unify inst_orig ctxt ty_actual ty_expected+  | definitely_poly ty_expected   -- See Note [Don't skolemise unnecessarily]+  , isRhoTyDS ds_flag ty_actual+  = do { traceTc "tc_sub_type (drop to equality)" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]+       ; mkWpCastN <$>+         unify ty_actual ty_expected }++  | otherwise   -- This is the general case+  = do { traceTc "tc_sub_type (general case)" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]++       ; (sk_wrap, inner_wrap)+            <- tcSkolemise ds_flag ctxt ty_expected $ \sk_rho ->+               case ds_flag of+                 Deep    -> tc_sub_type_deep pos unify inst_orig ctxt ty_actual sk_rho+                 Shallow -> tc_sub_type_shallow unify inst_orig ty_actual sk_rho++       ; return (sk_wrap <.> inner_wrap) }++----------------------+tc_sub_type_shallow :: (TcType -> TcType -> TcM TcCoercionN)+                    -> CtOrigin+                    -> TcSigmaType+                    -> TcRhoType   -- Skolemised (shallow-ly)+                    -> TcM HsWrapper+tc_sub_type_shallow unify inst_orig ty_actual sk_rho+  = do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual+       ; cow           <- unify rho_a sk_rho+       ; return (mkWpCastN cow <.> wrap) }++----------------------+definitely_poly :: TcType -> Bool+-- A very conservative test:+-- see Note [Don't skolemise unnecessarily]+definitely_poly ty+  | (tvs, theta, tau) <- tcSplitSigmaTy ty+  , (tv:_) <- tvs   -- At least one tyvar+  , null theta      -- No constraints; see (DP1)+  , tv `isInjectiveInType` tau+       -- The tyvar actually occurs (DP2),+       -- and occurs in an injective position (DP3).+  = True+  | otherwise+  = False++{- Note [Don't skolemise unnecessarily]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are trying to solve+     ty_actual   <= ty_expected+    (Char->Char) <= (forall a. a->a)+We could skolemise the 'forall a', and then complain+that (Char ~ a) is insoluble; but that's a pretty obscure+error.  It's better to say that+    (Char->Char) ~ (forall a. a->a)+fails.++If we prematurely go to equality we'll reject a program we should+accept (e.g. #13752).  So the test (which is only to improve error+message) is very conservative:++ * ty_actual   is /definitely/ monomorphic: see `definitely_mono`+   This definitely_mono test comes in "shallow" and "deep" variants++ * ty_expected is /definitely/ polymorphic: see `definitely_poly`+   This definitely_poly test is more subtle than you might think.+   Here are three cases where expected_ty looks polymorphic, but+   isn't, and where it would be /wrong/ to switch to equality:++   (DP1)  (Char->Char) <= (forall a. (a~Char) => a -> a)++   (DP2)  (Char->Char) <= (forall a. Char -> Char)++   (DP3)  (Char->Char) <= (forall a. F [a] Char -> Char)+                          where type instance F [x] t = t+++Note [Coercion errors in tcSubMult]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At the moment, we insist that all sub-multiplicity tests turn out+(once the typechecker has finished its work) to be equalities,+i.e. implementable by ReflCo.  Why?  Because our type system has+no way to express non-Refl sub-multiplicities.++How can we check that every call to `tcSubMult` returns `Refl`?+It might not be `Refl` *yet*.++[TODO: add counterexample #25130]++So we take the following approach++* In `tcEqMult`:+  - Emit a perfectly ordinary Wanted equality constraint for the equality,+    returning a coercion.++  - Wrap that coercion with `DE_Multiplicity` to make a `DelayedError`, and put+    that delayed error into `wc_errors` of the current WantedConstraints.  This+    is done by `ensureReflMultiplicityCo`.++* When solving constraints, discard any `DE_Multiplicity` errors that wrap a+  reflective coercion, of kind `ty ~ ty`.  This is done in+  `GHC.Tc.Solver.simplifyDelayedErrors`++* After constraint solving is complete report an error if there are any+  remaining `DE_Multiplicity` errors.  See+  `GHC.Tc.Errors.reportMultiplicityCoercionErrs`++Wrinkles++(DME1) If the multiplicity constraint is /solved/, but with a non-reflective+   coercion, we'll have just a `DE_Multiplicity` error left over.++   But if the multiplicity constraint is /unsolved/ (e.g. ManyTy ~ OneTy), we+   will have /both/ an unsolved Wanted in `wc_simple`, /and/ a `DE_Multiplicity`+   in `wc_errors`.  We don't want to report both.  Solution: suppress all+   `DE_Multiplicity` constraints if there are any unsolved wanted.++   This way, the delayed error is indeed only reported when the constraint is+   solved with a non-reflexivity coercion.++An alternative would be to have a kind of constraint which can only produce+trivial evidence. This would allow such checks to happen in the constraint+solver (#18756).  This would be similar to the existing setup for Concrete, see+Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete (PHASE 1 in particular).++-}++tcSubMult :: CtOrigin -> Mult -> Mult -> TcM ()+tcSubMult origin w_actual w_expected+  | Just (w1, w2) <- isMultMul w_actual =+  do { tcSubMult origin w1 w_expected+     ; tcSubMult origin w2 w_expected }+  -- Currently, we consider p*q and sup p q to be equal.  Therefore, p*q <= r is+  -- equivalent to p <= r and q <= r.  For other cases, we approximate p <= q by p+  -- ~ q.  This is not complete, but it's sound. See also Note [Overapproximating+  -- multiplicities] in Multiplicity.+tcSubMult origin w_actual w_expected =+  case submult w_actual w_expected of+    Submult -> return ()+    Unknown -> tcEqMult origin w_actual w_expected++tcEqMult :: CtOrigin -> Mult -> Mult -> TcM ()+tcEqMult origin w_actual w_expected = do+  {+  -- Note that here we do not call to `submult`, so we check+  -- for strict equality.+  ; coercion <- unifyTypeAndEmit TypeLevel origin w_actual w_expected+  -- See Note [Coercion errors in tcSubMult].+  ; ensureReflMultiplicityCo coercion origin }+++{- *********************************************************************+*                                                                      *+                    Deep subsumption+*                                                                      *+********************************************************************* -}++{- Note [Deep subsumption]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The DeepSubsumption extension, documented here++    https://github.com/ghc-proposals/ghc-proposals/pull/511.++makes a best-efforts attempt implement deep subsumption as it was+prior to the Simplify Subsumption proposal:++    https://github.com/ghc-proposals/ghc-proposals/pull/287++The effects are in these main places:++1. In the subsumption check, tcSubType, we must do deep skolemisation:+   see the call to tcSkolemise Deep in tc_sub_type_deep++2. In tcPolyExpr we must do deep skolemisation:+   see the call to tcSkolemise in tcSkolemiseExpType++3. for expression type signatures (e :: ty), and functions with type+   signatures (e.g. f :: ty; f = e), we must deeply skolemise the type;+   see the call to tcDeeplySkolemise in tcSkolemiseScoped.++4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result+   type. Without deep subsumption, tcSubTypeMono would be sufficent.++In all these cases note that the deep skolemisation must be done /first/.+Consider (1)+     (forall a. Int -> a -> a)  <=  Int -> (forall b. b -> b)+We must skolemise the `forall b` before instantiating the `forall a`.+See also Note [Deep skolemisation].++Wrinkles:++(DS1) Note that we /always/ use shallow subsumption in the ambiguity check.+      See Note [Ambiguity check and deep subsumption].++(DS2) When doing deep subsumption, we must be careful not to needlessly+      drop down to unification, e.g. in cases such as:+        (Bool -> ∀ d. d->d)   <=   alpha beta gamma+      See Note [FunTy vs non-FunTy case in tc_sub_type_deep].++(DS3) The interaction between deep subsumption and required foralls+      (forall a -> ty) is a bit subtle.  See #24696 and+      Note [Deep subsumption and required foralls]++Note [Deep skolemisation]+~~~~~~~~~~~~~~~~~~~~~~~~~+deeplySkolemise decomposes and skolemises a type, returning a type+with all its arrows visible (ie not buried under foralls)++Examples:++  deeplySkolemise (Int -> forall a. Ord a => blah)+    =  ( wp, [a], [d:Ord a], Int -> blah )+    where wp = \x:Int. /\a. \(d:Ord a). <hole> x++  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)+    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )+    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x++In general,+  if      deeplySkolemise ty = (wrap, tvs, evs, rho)+    and   e :: rho+  then    wrap e :: ty+    and   'wrap' binds tvs, evs++ToDo: this eta-abstraction plays fast and loose with termination,+      because it can introduce extra lambdas.  Maybe add a `seq` to+      fix this++Note [FunTy vs FunTy case in tc_sub_type_deep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The goal of tc_sub_type_deep is to produce an HsWrapper that "proves" that the+actual type is a subtype of the expected type. The most important case is how+we deal with function arrows. Suppose we have:++  ty_actual   = act_arg -> act_res+  ty_expected = exp_arg -> exp_res++To produce fun_wrap :: (act_arg -> act_res) ~> (exp_arg -> exp_res), we use+the fact that the function arrow is contravariant in its argument type and+covariant in its result type. Thus we recursively perform subtype checks+on the argument types (with actual/expected switched) and the result types,+to get:++  arg_wrap :: exp_arg ~> act_arg   -- NB: expected/actual have switched sides+  res_wrap :: act_res ~> exp_res++Then fun_wrap = mkWpFun arg_wrap res_wrap.++Wrinkle [Representation-polymorphism checking during subtyping]++  Inserting a WpFun HsWrapper amounts to impedance matching in deep subsumption+  via eta-expansion:++    f  ==>  \ (x :: exp_arg) -> res_wrap [ f (arg_wrap [x]) ]++  As we produce a lambda, we must enforce the representation polymorphism+  invariants described in Note [Representation polymorphism invariants] in GHC.Core.+  That is, we must ensure that both x (the lambda binder) and (arg_wrap [x]) (the function argument)+  have a fixed runtime representation.++  Note however that desugaring mkWpFun does not always introduce a lambda: if+  both the argument and result HsWrappers are casts, then a FunCo cast suffices,+  in which case we should not perform representation-polymorphism checking.++  This means that, in the FunTy/FunTy case of tc_sub_type_deep, we can skip+  the representation-polymorphism checks if the produced argument and result+  wrappers are identities or casts.+  It is important to do so, otherwise we reject valid programs.++    Here's a contrived example (there are undoubtedly more natural examples)+    (see testsuite/tests/rep-poly/NoEtaRequired):++      type Id :: k -> k+      type family Id a where++      type T :: TYPE r -> TYPE (Id r)+      type family T a where++      test :: forall r (a :: TYPE r). a :~~: T a -> ()+      test HRefl =+        let+          f :: (a -> a) -> ()+          f _ = ()+          g :: T a -> T a+          g = undefined+        in f g++    We don't need to eta-expand `g` to make `f g` typecheck; a cast suffices.+    Hence we should not perform representation-polymorphism checks; they would+    fail here.++Note [Setting the argument context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider we are doing the ambiguity check for the (bogus)+  f :: (forall a b. C b => a -> a) -> Int++We'll call+   tcSubType ((forall a b. C b => a->a) -> Int )+             ((forall a b. C b => a->a) -> Int )++with a UserTypeCtxt of (FunSigCtxt "f").  Then we'll do the co/contra thing+on the argument type of the (->) -- and at that point we want to switch+to a UserTypeCtxt of GenSigCtxt.  Why?++* Error messages.  If we stick with FunSigCtxt we get errors like+     * Could not deduce: C b+       from the context: C b0+        bound by the type signature for:+            f :: forall a b. C b => a->a+  But of course f does not have that type signature!+  Example tests: T10508, T7220a, Simple14++* Implications. We may decide to build an implication for the whole+  ambiguity check, but we don't need one for each level within it,+  and TcUnify.alwaysBuildImplication checks the UserTypeCtxt.+  See Note [When to build an implication]++Note [Multiplicity in deep subsumption]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   t1 ->{mt} t2  <=   s1 ->{ms} s2++At the moment we /unify/ ms~mt, via tcEqMult.++Arguably we should use `tcSubMult`. But then if mt=m0 (a unification+variable) and ms=Many, `tcSubMult` is a no-op (since anything is a+sub-multiplicty of Many).  But then `m0` may never get unified with+anything.  It is then skolemised by the zonker; see GHC.HsToCore.Binds+Note [Free tyvars on rule LHS].  So we in RULE foldr/app in GHC.Base+we get this++ "foldr/app"     [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys+                                       = \xs -> xs ++ ys++where we eta-expanded that (:).  But now foldr expects an argument+with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint+complains.++The easiest solution was to unify the multiplicities in tc_sub_type_deep,+insisting on equality. This is only in the DeepSubsumption code anyway.++Note [FunTy vs non-FunTy case in tc_sub_type_deep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this, without Quick Look, but with Deep Subsumption:+   f :: ∀a b c. a b c -> Int+   g :: Bool -> ∀d. d -> d+To typecheck the application (f g), we need to do the subsumption test++  (Bool -> ∀ d. d->d)   <=   alpha beta gamma++where alpha, beta, gamma are the unification variables that instantiate a,b,c+(respectively). We must not drop down to unification, or we will reject the call.+Instead, we should only unify alpha := (->), in which case we end up with the+usual FunTy vs FunTy case of Note [FunTy vs FunTy case in tc_sub_type_deep]:++  (Bool -> ∀ d. d->d)   <=   beta -> gamma++which is straightforwardly solved by beta := Bool, using covariance in the return+type of the function arrow, and instantiating the forall before unifying with gamma.++The conclusion is this: when doing a deep subtype check (in tc_sub_type_deep),+if the LHS is a FunTy and the RHS is a rho-type which is not a FunTy,+then unify the RHS with a FunTy and continue by performing a sub-type check on+the LHS vs the new RHS. And vice-versa (if it's the RHS that is a FunTy).++See T11305 and T26225 for examples of when this is important.++Note [Deep subsumption and required foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A required forall, (forall a -> ty) behaves like a "rho-type", one with no+top-level quantification.  In particular, it is neither implicitly instantiated nor+skolemised.  So++  rid1 :: forall a -> a -> a+  rid1 = id++  rid2 :: forall a -> a -> a+  rid2 a = id++Here `rid2` wll typecheck, but `rid1` will not, because we don't implicitly skolemise+the  type.++This "no implicit subsumption nor skolemisation" applies during subsumption.+For example+   (forall a. a->a)  <=  (forall a -> a -> a)  -- NOT!+does /not/ hold, because that would require implicitly skoleming the (forall a->).++Note also that, in Core, `eqType` distinguishes between+   (forall a. blah) and forall a -> blah)+See discussion on #22762 and these Notes in GHC.Core.TyCo.Compare+  * Note [ForAllTy and type equality]+  * Note [Comparing visibility]++So during deep subsumption we simply stop (and drop down to equality) when we encounter+a (forall a->).  This is a little odd:+* Deep subsumption looks inside invisible foralls (forall a. ty)+* Deep subsumption looks inside arrows (t1 -> t2)+* But it does not look inside required foralls (forall a -> ty)++There is discussion on #24696.  How is this implemented?++* In `tc_sub_type_deep`, the calls to `topInstantiate` and `deeplyInstantiate`+  instantiate only /invisible/ binders.+* In `tc_sub_type_ds`, the call to `tcSkolemise` skolemises only /invisible/+  binders.++Here is a slightly more powerful alternative+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ In the story above, if we have+    (forall a -> Eq a => a -> a)  <=  (forall a -> Ord a => a -> a)+we'll reject it, because both are rho-types but they aren't equal.  But in the+"drop to equality" stage we could instead see if both rho-types are headed with+(forall a ->) and if so strip that off and go back into deep subsumption.++This is a bit more powerful, but also a bit more complicated, so GHC+doesn't do it yet, awaiting credible user demand.  See #24696.+-}++data DeepSubsumptionFlag = Deep | Shallow++instance Outputable DeepSubsumptionFlag where+    ppr Deep    = text "Deep"+    ppr Shallow = text "Shallow"++getDeepSubsumptionFlag :: TcM DeepSubsumptionFlag+getDeepSubsumptionFlag = do { ds <- xoptM LangExt.DeepSubsumption+                            ; if ds then return Deep else return Shallow }++-- | 'tc_sub_type_deep' is where the actual work happens for deep subsumption.+--+-- Given @ty_actual@ (a sigma-type) and @ty_expected@ (deeply skolemised, i.e.+-- a deep rho type), it returns an 'HsWrapper' @wrap :: ty_actual ~> ty_expected@.+tc_sub_type_deep :: HasDebugCallStack+                 => Position p     -- ^ Position in the type (for error messages only)+                 -> (TcType -> TcType -> TcM TcCoercionN) -- ^ How to unify+                 -> CtOrigin       -- ^ Used when instantiating+                 -> UserTypeCtxt   -- ^ Used when skolemising+                 -> TcSigmaType    -- ^ Actual; a sigma-type+                 -> TcRhoType      -- ^ Expected; deeply skolemised+                 -> TcM HsWrapper++-- If wrap = tc_sub_type_deep t1 t2+--    => wrap :: t1 ~> t2+-- Here is where the work actually happens!+-- Precondition: ty_expected is deeply skolemised++tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected+  = assertPpr (isDeepRhoTy ty_expected) (ppr ty_expected) $+    do { traceTc "tc_sub_type_deep" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]+       ; go ty_actual ty_expected }+  where++    -- 'unwrap' removes top-level type synonyms & looks through filled meta-tyvars+    unwrap :: TcType -> TcM TcType+    unwrap ty+      | Just ty' <- coreView ty+      = unwrap ty'+    unwrap ty@(TyVarTy tv)+      = do { lookup_res <- isFilledMetaTyVar_maybe tv+           ; case lookup_res of+                 Just ty' -> unwrap ty'+                 Nothing  -> return ty }+    unwrap ty = return ty++    go, go1 :: TcType -> TcType -> TcM HsWrapper+    go ty_a ty_e =+      do { ty_a' <- unwrap ty_a+         ; ty_e' <- unwrap ty_e+         ; go1 ty_a' ty_e' }++    -- If ty_actual is not a rho-type, instantiate it first; otherwise+    -- unification has no chance of succeeding.+    go1 ty_a ty_e+      | let (tvs, theta, _) = tcSplitSigmaTy ty_a+      , not (null tvs && null theta)+      = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a+           ; body_wrap <- go in_rho ty_e+           ; return (body_wrap <.> in_wrap) }++    -- Main case: FunTy vs FunTy. go_fun does the work.+    go1 (FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res })+        (FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res })+      | isVisibleFunArg af1+      , isVisibleFunArg af2+      = go_fun af1 act_mult act_arg act_res+               af2 exp_mult exp_arg exp_res++    -- See Note [FunTy vs non-FunTy case in tc_sub_type_deep]+    go1 (FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) ty_e+      | isVisibleFunArg af1+      = do { exp_mult <- newMultiplicityVar+           ; exp_arg  <- newOpenFlexiTyVarTy -- NB: no FRR check needed; we might not need to eta-expand+           ; exp_res  <- newOpenFlexiTyVarTy+           ; let exp_funTy = FunTy { ft_af = af1, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }+           ; unify_wrap <- just_unify exp_funTy ty_e+           ; fun_wrap <- go_fun af1 act_mult act_arg act_res af1 exp_mult exp_arg exp_res+           ; return $ unify_wrap <.> fun_wrap+             -- unify_wrap :: exp_funTy ~> ty_e+             -- fun_wrap :: ty_a ~> exp_funTy+           }+    go1 ty_a (FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res })+      | isVisibleFunArg af2+      = do { act_mult <- newMultiplicityVar+           ; act_arg  <- newOpenFlexiTyVarTy -- NB: no FRR check needed; we might not need to eta-expand+           ; act_res  <- newOpenFlexiTyVarTy+           ; let act_funTy = FunTy { ft_af = af2, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }++           ; unify_wrap <- just_unify ty_a act_funTy+           ; fun_wrap <- go_fun af2 act_mult act_arg act_res af2 exp_mult exp_arg exp_res+           ; return $ fun_wrap <.> unify_wrap+             -- unify_wrap :: ty_a ~> act_funTy+             -- fun_wrap :: act_funTy ~> ty_e+           }++    -- Otherwise, revert to unification.+    go1 ty_a ty_e = just_unify ty_a ty_e++    just_unify ty_a ty_e = do { cow <- unify ty_a ty_e+                              ; return (mkWpCastN cow) }++    -- FunTy/FunTy case: this is where we insert any necessary eta-expansions.+    go_fun :: FunTyFlag -> Mult -> TcType -> TcType -- actual FunTy+           -> FunTyFlag -> Mult -> TcType -> TcType -- expected FunTy+           -> TcM HsWrapper+    go_fun act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res+      -- See Note [FunTy vs FunTy case in tc_sub_type_deep]+      = do { arg_wrap  <- tc_sub_type_ds (Argument pos) Deep unify given_orig GenSigCtxt exp_arg act_arg+                          -- GenSigCtxt: See Note [Setting the argument context]+           ; res_wrap  <- tc_sub_type_deep (Result pos) unify inst_orig ctxt act_res exp_res++           ; mkWpFun_FRR unify pos+               act_af act_mult act_arg act_res+               exp_af exp_mult exp_arg exp_res+               arg_wrap res_wrap+           }+      where+        given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])++-- | Like 'mkWpFun', except that it performs the necessary+-- representation-polymorphism checks on the argument type in the case that+-- we introduce a lambda abstraction.+mkWpFun_FRR+  :: (TcType -> TcType -> TcM TcCoercionN) -- ^ how to unify+  -> Position p+  -> FunTyFlag -> Type -> TcType -> Type --   actual FunTy+  -> FunTyFlag -> Type -> TcType -> Type -- expected FunTy+  -> HsWrapper -- ^ exp_arg ~> act_arg+  -> HsWrapper -- ^ act_res ~> exp_res+  -> TcM HsWrapper -- ^ act_funTy ~> exp_funTy+mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap+  = do { ((exp_arg_co, exp_arg_frr), (act_arg_co, _act_arg_frr)) <-+            if needs_frr_checks+              -- See Wrinkle [Representation-polymorphism checking during subtyping]+            then do { exp_frr_wrap <- hasFixedRuntimeRep (frr_ctxt True ) exp_arg+                    ; act_frr_wrap <- hasFixedRuntimeRep (frr_ctxt False) act_arg+                    ; return (exp_frr_wrap, act_frr_wrap) }+            else return ((mkNomReflCo exp_arg, exp_arg), (mkNomReflCo act_arg, act_arg))++         -- Enforce equality of multiplicities (not the more natural sub-multiplicity).+         -- See Note [Multiplicity in deep subsumption]+       ; act_arg_mult_co <- unify act_mult exp_mult+           -- NB: don't use tcEqMult: that would require the evidence for+           -- equality to be Refl, but it might well not be (#26332).++       ; let+            exp_arg_fun_co =+              mkFunCo Nominal exp_af+                 (mkReflCo Nominal exp_mult)+                 (mkSymCo exp_arg_co)+                 (mkReflCo Nominal exp_res)+            act_arg_fun_co =+              mkFunCo Nominal act_af+                 act_arg_mult_co+                 act_arg_co+                 (mkReflCo Nominal act_res)+            arg_wrap_frr =+              mkWpCastN (mkSymCo exp_arg_co) <.> arg_wrap <.> mkWpCastN act_arg_co+               --  exp_arg_co :: exp_arg ~> exp_arg_frr+               --  act_arg_co :: act_arg ~> act_arg_frr+               --  arg_wrap :: exp_arg ~> act_arg+               --  arg_wrap_frr :: exp_arg_frr ~> act_arg_frr++       ; return $+            mkWpCastN exp_arg_fun_co+              <.>+            mkWpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) exp_res+              <.>+            mkWpCastN act_arg_fun_co+       }+  where+    needs_frr_checks :: Bool+    needs_frr_checks =+      not (hole_or_cast arg_wrap)+        ||+      not (hole_or_cast res_wrap)+    hole_or_cast :: HsWrapper -> Bool+    hole_or_cast WpHole = True+    hole_or_cast (WpCast {}) = True+    hole_or_cast _ = False+    frr_ctxt :: Bool -> FixedRuntimeRepContext+    frr_ctxt is_exp_ty =+      FRRDeepSubsumption+        { frrDSExpected = is_exp_ty+        , frrDSPosition = pos+        }++-----------------------+deeplySkolemise :: SkolemInfo -> TcSigmaType+                -> TcM ( HsWrapper+                       , [(Name,TcInvisTVBinder)]     -- All skolemised variables+                       , [EvVar]                      -- All "given"s+                       , TcRhoType )+-- See Note [Deep skolemisation]+deeplySkolemise skol_info ty+  = go init_subst ty+  where+    init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))++    go subst ty+      | Just (arg_tys, bndrs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty+      = do { let arg_tys' = substScaledTys subst arg_tys+           ; ids1             <- newSysLocalIds (fsLit "dk") arg_tys'+           ; (subst', bndrs1) <- tcInstSkolTyVarBndrsX skol_info subst bndrs+           ; ev_vars1         <- newEvVars (substTheta subst' theta)+           ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'+           ; let tvs     = binderVars bndrs+                 tvs1    = binderVars bndrs1+                 tv_prs1 = map tyVarName tvs `zip` bndrs1+           ; return ( mkWpEta ids1 (mkWpTyLams tvs1+                                    <.> mkWpEvLams ev_vars1+                                    <.> wrap)+                    , tv_prs1  ++ tvs_prs2+                    , ev_vars1 ++ ev_vars2+                    , mkScaledFunTys arg_tys' rho ) }++      | otherwise+      = return (idHsWrapper, [], [], substTy subst ty)+        -- substTy is a quick no-op on an empty substitution++dsInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)+-- Do topInstantiate or deeplyInstantiate, depending on -XDeepSubsumption+dsInstantiate orig ty+  = do { ds_flag <- getDeepSubsumptionFlag+       ; case ds_flag of+           Shallow -> topInstantiate    orig ty+           Deep    -> deeplyInstantiate orig ty }++deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)+-- Instantiate invisible foralls, even ones nested+-- (to the right) under arrows+deeplyInstantiate orig ty+  = go init_subst ty+  where+    init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))++    go subst ty+      | Just (arg_tys, bndrs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty+      = do { let tvs = binderVars bndrs+           ; (subst', tvs') <- newMetaTyVarsX subst tvs+           ; let arg_tys' = substScaledTys   subst' arg_tys+                 theta'   = substTheta subst' theta+           ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'+           ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'+           ; (wrap2, rho2) <- go subst' rho+           ; return (mkWpEta ids1 (wrap2 <.> wrap1),+                     mkScaledFunTys arg_tys' rho2) }++      | otherwise+      = do { let ty' = substTy subst ty+           ; return (idHsWrapper, ty') }++tcDeepSplitSigmaTy_maybe+  :: TcSigmaType -> Maybe ([Scaled TcType], [TcInvisTVBinder], ThetaType, TcSigmaType)+-- Looks for a *non-trivial* quantified type, under zero or more function arrows+-- By "non-trivial" we mean either tyvars or constraints are non-empty+tcDeepSplitSigmaTy_maybe ty+  = go ty+  where+  go ty | Just (arg_ty, res_ty)           <- tcSplitFunTy_maybe ty+        , Just (arg_tys, tvs, theta, rho) <- go res_ty+        = Just (arg_ty:arg_tys, tvs, theta, rho)++        | (tvs, theta, rho) <- tcSplitSigmaTyBndrs ty+        , not (null tvs && null theta)+        = Just ([], tvs, theta, rho)++        | otherwise = Nothing++isDeepRhoTy :: TcType -> Bool+-- True if there are no foralls or (=>) at the top, or nested under+-- arrows to the right.  e.g+--    forall a. a                  False+--    Int -> forall a. a           False+--    (forall a. a) -> Int         True+-- Returns True iff tcDeepSplitSigmaTy_maybe returns Nothing+isDeepRhoTy ty+  | not (isRhoTy ty)                       = False  -- Foralls or (=>) at top+  | Just (_, res) <- tcSplitFunTy_maybe ty = isDeepRhoTy res+  | otherwise                              = True   -- No forall, (=>), or (->) at top++isRhoTyDS :: DeepSubsumptionFlag -> TcType -> Bool+isRhoTyDS ds_flag ty+  = case ds_flag of+      Shallow -> isRhoTy ty      -- isRhoTy: no top level forall or (=>)+      Deep    -> isDeepRhoTy ty  -- "deep" version: no nested forall or (=>)++{-+************************************************************************+*                                                                      *+                Boxy unification+*                                                                      *+************************************************************************++The exported functions are all defined as versions of some+non-exported generic functions.+-}++unifyExprType :: HsExpr GhcRn -> TcType -> TcType -> TcM TcCoercionN+unifyExprType rn_expr ty1 ty2+  = unifyType (Just (HsExprRnThing rn_expr)) ty1 ty2++unifyType :: Maybe TypedThing  -- ^ If present, the thing that has type ty1+          -> TcTauType -> TcTauType    -- ty1 (actual), ty2 (expected)+          -> TcM TcCoercionN           -- :: ty1 ~# ty2+-- Actual and expected types+-- Returns a coercion : ty1 ~ ty2+unifyType thing ty1 ty2+  = unifyTypeAndEmit TypeLevel origin ty1 ty2+  where+    origin = TypeEqOrigin { uo_actual   = ty1+                          , uo_expected = ty2+                          , uo_thing    = thing+                          , uo_visible  = True }++unifyInvisibleType :: TcTauType -> TcTauType    -- ty1 (actual), ty2 (expected)+                   -> TcM TcCoercionN           -- :: ty1 ~# ty2+-- Actual and expected types+-- Returns a coercion : ty1 ~ ty2+unifyInvisibleType ty1 ty2+  = unifyTypeAndEmit TypeLevel origin ty1 ty2+  where+    origin = TypeEqOrigin { uo_actual   = ty1+                          , uo_expected = ty2+                          , uo_thing    = Nothing+                          , uo_visible  = False }  -- This is the "invisible" bit++unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN+-- Like unifyType, but swap expected and actual in error messages+-- This is used when typechecking patterns+unifyTypeET ty1 ty2+  = unifyTypeAndEmit TypeLevel origin ty1 ty2+  where+    origin = TypeEqOrigin { uo_actual   = ty2   -- NB swapped+                          , uo_expected = ty1   -- NB swapped+                          , uo_thing    = Nothing+                          , uo_visible  = True }+++unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN+unifyKind mb_thing ty1 ty2+  = unifyTypeAndEmit KindLevel origin ty1 ty2+  where+    origin = TypeEqOrigin { uo_actual   = ty1+                          , uo_expected = ty2+                          , uo_thing    = mb_thing+                          , uo_visible  = True }++unifyTypeAndEmit :: TypeOrKind -> CtOrigin -> TcType -> TcType -> TcM CoercionN+-- Make a ref-cell, unify, emit the collected constraints+unifyTypeAndEmit t_or_k orig ty1 ty2+  = do { ref <- newTcRef emptyBag+       ; loc <- getCtLocM orig (Just t_or_k)+       ; let env = UE { u_loc = loc, u_role = Nominal+                      , u_rewriters = emptyRewriterSet  -- ToDo: check this+                      , u_defer = ref, u_unified = Nothing }++       -- The hard work happens here+       ; co <- uType env ty1 ty2++       ; cts <- readTcRef ref+       ; unless (null cts) (emitSimples cts)+       ; return co }++{-+%************************************************************************+%*                                                                      *+                 uType and friends+%*                                                                      *+%************************************************************************++Note [The eager unifier]+~~~~~~~~~~~~~~~~~~~~~~~~+The eager unifier, `uType`, is called by++  * The constraint generator (e.g. in GHC.Tc.Gen.Expr),+    via the wrappers `unifyType`, `unifyKind` etc++  * The constraint solver (e.g. in GHC.Tc.Solver.Equality),+    via `GHC.Tc.Solver.Monad.wrapUnifierTcS`.++`uType` runs in the TcM monad, but it carries a UnifyEnv that tells it+what to do when unifying a variable or deferring a constraint. Specifically,+  * it collects deferred constraints in `u_defer`, and+  * it records which unification variables it has unified in `u_unified`+Then it is up to the wrappers (one for the constraint generator, one for+the constraint solver) to deal with these collected sets.++Although `uType` runs in the TcM monad for convenience, really it could+operate just with the ability to+  * write to the accumulators of deferred constraints+    and unification variables in UnifyEnv.+  * read and update existing unification variables+  * zonk types befire unifying (`zonkTcType` in `uUnfilledVar`, and+    `zonkTyCoVarKind` in `uUnfilledVar1`+  * create fresh coercion holes (`newCoercionHole`)+  * emit tracing info for debugging+  * look at the ambient TcLevel: `getTcLevel`+A job for the future.+-}++data UnifyEnv+  = UE { u_role      :: Role+       , u_loc       :: CtLoc+       , u_rewriters :: RewriterSet++         -- Deferred constraints+       , u_defer     :: TcRef (Bag Ct)++         -- Which variables are unified;+         -- if Nothing, we don't care+       , u_unified :: Maybe (TcRef [TcTyVar])+    }++setUEnvRole :: UnifyEnv -> Role -> UnifyEnv+setUEnvRole uenv role = uenv { u_role = role }++updUEnvLoc :: UnifyEnv -> (CtLoc -> CtLoc) -> UnifyEnv+updUEnvLoc uenv@(UE { u_loc = loc }) upd = uenv { u_loc = upd loc }++mkKindEnv :: UnifyEnv -> TcType -> TcType -> UnifyEnv+-- Modify the UnifyEnv to be right for unifing+-- the kinds of these two types+mkKindEnv env@(UE { u_loc = ctloc }) ty1 ty2+  = env { u_role = Nominal, u_loc = mkKindEqLoc ty1 ty2 ctloc }++uType, uType_defer+  :: UnifyEnv+  -> TcType    -- ty1 is the *actual* type+  -> TcType    -- ty2 is the *expected* type+  -> TcM CoercionN++-- It is always safe to defer unification to the main constraint solver+-- See Note [Deferred unification]+uType_defer (UE { u_loc = loc, u_defer = ref+                , u_role = role, u_rewriters = rewriters })+            ty1 ty2  -- ty1 is "actual", ty2 is "expected"+  = do { let pred_ty = mkEqPredRole role ty1 ty2+       ; hole <- newCoercionHole pred_ty+       ; let ct = mkNonCanonical $ CtWanted $+                    WantedCt { ctev_pred      = pred_ty+                             , ctev_dest      = HoleDest hole+                             , ctev_loc       = loc+                             , ctev_rewriters = rewriters }+             co = HoleCo hole+       ; updTcRef ref (`snocBag` ct)+         -- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality++       -- Error trace only+       -- NB. do *not* call mkErrCtxt unless tracing is on,+       --     because it is hugely expensive (#5631)+       ; whenDOptM Opt_D_dump_tc_trace $+         do { ctxt     <- getErrCtxt+            ; err_ctxt <- mkErrCtxt emptyTidyEnv ctxt+            ; traceTc "utype_defer" $+                vcat ( ppr role+                     : debugPprType ty1+                     : debugPprType ty2+                     : map pprErrCtxtMsg err_ctxt )+            ; traceTc "utype_defer2" (ppr co) }++       ; return co }+++--------------+uType env@(UE { u_role = role }) orig_ty1 orig_ty2+  | Phantom <- role+  = do { kind_co <- uType (mkKindEnv env orig_ty1 orig_ty2)+                          (typeKind orig_ty1) (typeKind orig_ty2)+       ; return (mkPhantomCo kind_co orig_ty1 orig_ty2) }++  | otherwise+  = do { tclvl <- getTcLevel+       ; traceTc "u_tys" $ vcat+              [ text "tclvl" <+> ppr tclvl+              , sep [ ppr orig_ty1, text "~" <> ppr role, ppr orig_ty2] ]+       ; co <- go orig_ty1 orig_ty2+       ; if isReflCo co+            then traceTc "u_tys yields no coercion" Outputable.empty+            else traceTc "u_tys yields coercion:" (ppr co)+       ; return co }+  where+    go :: TcType -> TcType -> TcM CoercionN+        -- The arguments to 'go' are always semantically identical+        -- to orig_ty{1,2} except for looking through type synonyms++     -- Unwrap casts before looking for variables. This way, we can easily+     -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we+     -- didn't do it this way, and then the unification above was deferred.+    go (CastTy t1 co1) t2+      = do { co_tys <- uType env t1 t2+           ; return (mkCoherenceLeftCo role t1 co1 co_tys) }++    go t1 (CastTy t2 co2)+      = do { co_tys <- uType env t1 t2+           ; return (mkCoherenceRightCo role t2 co2 co_tys) }++        -- Variables; go for uUnfilledVar+        -- Note that we pass in *original* (before synonym expansion),+        -- so that type variables tend to get filled in with+        -- the most informative version of the type+    go (TyVarTy tv1) ty2+      = do { lookup_res <- isFilledMetaTyVar_maybe tv1+           ; case lookup_res of+               Just ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)+                              ; uType env ty1 orig_ty2 }+               Nothing -> uUnfilledVar env NotSwapped tv1 ty2 }++    go ty1 (TyVarTy tv2)+      = do { lookup_res <- isFilledMetaTyVar_maybe tv2+           ; case lookup_res of+               Just ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)+                              ; uType env orig_ty1 ty2 }+               Nothing -> uUnfilledVar env IsSwapped tv2 ty1 }++      -- See Note [Unifying type synonyms] in GHC.Core.Unify+    go ty1@(TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = return $ mkReflCo role ty1++        -- Now expand synonyms+        -- See Note [Expanding synonyms during unification]+        --+        -- Also NB that we recurse to 'go' so that we don't push a+        -- new item on the origin stack. As a result if we have+        --   type Foo = Int+        -- and we try to unify  Foo ~ Bool+        -- we'll end up saying "can't match Foo with Bool"+        -- rather than "can't match "Int with Bool".  See #4535.+    go ty1 ty2+      | Just ty1' <- coreView ty1 = go ty1' ty2+      | Just ty2' <- coreView ty2 = go ty1  ty2'++    -- Functions (t1 -> t2) just check the two parts+    go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 })+       (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 })+      | isVisibleFunArg af1  -- Do not attempt (c => t); just defer+      , af1 == af2           -- Important!  See #21530+      = do { co_w <- uType (env { u_role = funRole role SelMult }) w1   w2+           ; co_l <- uType (env { u_role = funRole role SelArg })  arg1 arg2+           ; co_r <- uType (env { u_role = funRole role SelRes })  res1 res2+           ; return $ mkNakedFunCo role af1 co_w co_l co_r }++        -- Always defer if a type synonym family (type function)+        -- is involved.  (Data families behave rigidly.)+    go ty1@(TyConApp tc1 _) ty2+      | isTypeFamilyTyCon tc1 = defer ty1 ty2+    go ty1 ty2@(TyConApp tc2 _)+      | isTypeFamilyTyCon tc2 = defer ty1 ty2++    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      -- See Note [Mismatched type lists and application decomposition]+      | tc1 == tc2, equalLength tys1 tys2+      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality+      = assertPpr (isGenerativeTyCon tc1 role) (ppr tc1) $+        do { traceTc "go-tycon" (ppr tc1 $$ ppr tys1 $$ ppr tys2 $$ ppr (take 10 (tyConRoleListX role tc1)))+           ; cos <- zipWith4M u_tc_arg (tyConVisibilities tc1)   -- Infinite+                                       (tyConRoleListX role tc1) -- Infinite+                                       tys1 tys2+           ; return $ mkTyConAppCo role tc1 cos }++    go (LitTy m) ty@(LitTy n)+      | m == n+      = return $ mkReflCo role ty++        -- See Note [Care with type applications]+        -- Do not decompose FunTy against App;+        -- it's often a type error, so leave it for the constraint solver+    go ty1@(AppTy s1 t1) ty2@(AppTy s2 t2)+      = go_app (isNextArgVisible s1) ty1 s1 t1 ty2 s2 t2++    go ty1@(AppTy s1 t1) ty2@(TyConApp tc2 ts2)+      | Just (ts2', t2') <- snocView ts2+      = assert (not (tyConMustBeSaturated tc2)) $+        go_app (isNextTyConArgVisible tc2 ts2')+               ty1 s1 t1 ty2 (TyConApp tc2 ts2') t2'++    go ty1@(TyConApp tc1 ts1) ty2@(AppTy s2 t2)+      | Just (ts1', t1') <- snocView ts1+      = assert (not (tyConMustBeSaturated tc1)) $+        go_app (isNextTyConArgVisible tc1 ts1')+               ty1 (TyConApp tc1 ts1') t1' ty2 s2 t2++    go ty1@(CoercionTy co1) ty2@(CoercionTy co2)+      = do { kco <- uType (mkKindEnv env ty1 ty2)+                          (coercionType co1) (coercionType co2)+           ; return $ mkProofIrrelCo role kco co1 co2 }++        -- Anything else fails+        -- E.g. unifying for-all types, which is relative unusual+    go ty1 ty2 = defer ty1 ty2++    ------------------+    defer ty1 ty2   -- See Note [Check for equality before deferring]+      | ty1 `tcEqType` ty2 = return (mkReflCo role ty1)+      | otherwise          = uType_defer env orig_ty1 orig_ty2+++    ------------------+    u_tc_arg is_vis role ty1 ty2+      = do { traceTc "u_tc_arg" (ppr role $$ ppr ty1 $$ ppr ty2)+           ; uType env_arg ty1 ty2 }+      where+        env_arg = env { u_loc = adjustCtLoc is_vis False (u_loc env)+                      , u_role = role }++    ------------------+    -- For AppTy, decompose only nominal equalities+    -- See Note [Decomposing AppTy equalities] in GHC.Tc.Solver.Equality+    go_app vis ty1 s1 t1 ty2 s2 t2+      | Nominal <- role+      = -- Unify arguments t1/t2 before function s1/s2, because+        -- the former have smaller kinds, and hence simpler error messages+        -- c.f. GHC.Tc.Solver.Equality.can_eq_app+        -- Example: test T8603+        do { let env_arg = env { u_loc = adjustCtLoc vis False (u_loc env) }+           ; co_t <- uType env_arg t1 t2+           ; co_s <- uType env s1 s2+           ; return $ mkAppCo co_s co_t }+      | otherwise+      = defer ty1 ty2++{- Note [Check for equality before deferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Particularly in ambiguity checks we can get equalities like (ty ~ ty).+If ty involves a type function we may defer, which isn't very sensible.+An egregious example of this was in test T9872a, which has a type signature+       Proxy :: Proxy (Solutions Cubes)+Doing the ambiguity check on this signature generates the equality+   Solutions Cubes ~ Solutions Cubes+and currently the constraint solver normalises both sides at vast cost.+This little short-cut in 'defer' helps quite a bit.++Note [Care with type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note: type applications need a bit of care!+They can match FunTy and TyConApp, so use splitAppTy_maybe+NB: we've already dealt with type variables and Notes,+so if one type is an App the other one jolly well better be too++Note [Mismatched type lists and application decomposition]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we find two TyConApps, you might think that the argument lists+are guaranteed equal length.  But they aren't. Consider matching+        w (T x) ~ Foo (T x y)+We do match (w ~ Foo) first, but in some circumstances we simply create+a deferred constraint; and then go ahead and match (T x ~ T x y).+This came up in #3950.++So either+   (a) either we must check for identical argument kinds+       when decomposing applications,++   (b) or we must be prepared for ill-kinded unification sub-problems++Currently we adopt (b) since it seems more robust -- no need to maintain+a global invariant.++Note [Expanding synonyms during unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We expand synonyms during unification, but:+ * We expand *after* the variable case so that we tend to unify+   variables with un-expanded type synonym. This just makes it+   more likely that the inferred types will mention type synonyms+   understandable to the user++ * Similarly, we expand *after* the CastTy case, just in case the+   CastTy wraps a variable.++ * We expand *before* the TyConApp case.  For example, if we have+      type Phantom a = Int+   and are unifying+      Phantom Int ~ Phantom Char+   it is *wrong* to unify Int and Char.++ * The problem case immediately above can happen only with arguments+   to the tycon. So we check for nullary tycons *before* expanding.+   This is particularly helpful when checking (* ~ *), because * is+   now a type synonym.  See Note [Unifying type synonyms] in GHC.Core.Unify.++Note [Deferred unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,+and yet its consistency is undetermined. Previously, there was no way to still+make it consistent. So a mismatch error was issued.++Now these unifications are deferred until constraint simplification, where type+family instances and given equations may (or may not) establish the consistency.+Deferred unifications are of the form+                F ... ~ ...+or              x ~ ...+where F is a type function and x is a type variable.+E.g.+        id :: x ~ y => x -> y+        id e = e++involves the unification x = y. It is deferred until we bring into account the+context x ~ y to establish that it holds.++If available, we defer original types (rather than those where closed type+synonyms have already been expanded via tcCoreView).  This is, as usual, to+improve error messages.++************************************************************************+*                                                                      *+                 uUnfilledVar and friends+*                                                                      *+************************************************************************++@uunfilledVar@ is called when at least one of the types being unified is a+variable.  It does {\em not} assume that the variable is a fixed point+of the substitution; rather, notice that @uVar@ (defined below) nips+back into @uTys@ if it turns out that the variable is already bound.+-}++----------+uUnfilledVar, uUnfilledVar1+    :: UnifyEnv+    -> SwapFlag+    -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar+                      --    definitely not a /filled/ meta-tyvar+    -> TcTauType      -- Type 2+    -> TcM CoercionN+-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar+--            It might be a skolem, or untouchable, or meta+uUnfilledVar env swapped tv1 ty2+  | Nominal <- u_role env+  = do { ty2 <- liftZonkM $ zonkTcType ty2+                  -- Zonk to expose things to the occurs check, and so+                  -- that if ty2 looks like a type variable then it+                  -- /is/ a type variable+       ; uUnfilledVar1 env swapped tv1 ty2 }++  | otherwise  -- See Note [Do not unify representational equalities]+               -- in GHC.Tc.Solver.Equality+  = unSwap swapped (uType_defer env) (mkTyVarTy tv1) ty2++uUnfilledVar1 env       -- Precondition: u_role==Nominal+              swapped+              tv1+              ty2       -- ty2 is zonked+  | Just tv2 <- getTyVar_maybe ty2+  = go tv2++  | otherwise+  = uUnfilledVar2 env swapped tv1 ty2++  where+    -- 'go' handles the case where both are+    -- tyvars so we might want to swap+    -- E.g. maybe tv2 is a meta-tyvar and tv1 is not+    go tv2 | tv1 == tv2  -- Same type variable => no-op+           = return (mkNomReflCo (mkTyVarTy tv1))++           | swapOverTyVars False tv1 tv2   -- Distinct type variables+               -- Swap meta tyvar to the left if poss+           = do { tv1 <- liftZonkM $ zonkTyCoVarKind tv1+                     -- We must zonk tv1's kind because that might+                     -- not have happened yet, and it's an invariant of+                     -- uUnfilledTyVar2 that ty2 is fully zonked+                     -- Omitting this caused #16902+                ; uUnfilledVar2 env (flipSwap swapped) tv2 (mkTyVarTy tv1) }++           | otherwise+           = uUnfilledVar2 env swapped tv1 ty2++----------+uUnfilledVar2 :: UnifyEnv       -- Precondition: u_role==Nominal+              -> SwapFlag+              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar+                                --    definitely not a /filled/ meta-tyvar+              -> TcTauType      -- Type 2, zonked+              -> TcM CoercionN+uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2+  = do { cur_lvl <- getTcLevel+           -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles+           -- Here we don't know about given equalities; so we treat+           -- /any/ level outside this one as untouchable.  Hence cur_lvl.+       ; if simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2 /= SUC_CanUnify+         then not_ok_so_defer cur_lvl+         else+    do { def_eqs <- readTcRef def_eq_ref  -- Capture current state of def_eqs++       -- Attempt to unify kinds+       -- When doing so, be careful to preserve orientation;+       --    see Note [Kind Equality Orientation] in GHC.Tc.Solver.Equality+       --    and wrinkle (W2) in Note [Fundeps with instances, and equality orientation]+       --        in GHC.Tc.Solver.Dict+       -- Failing to preserve orientation led to #25597.+       ; let kind_env = unSwap swapped (mkKindEnv env) ty1 ty2+       ; co_k <- unSwap swapped (uType kind_env) (tyVarKind tv1) (typeKind ty2)++       ; traceTc "uUnfilledVar2 ok" $+         vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)+              , ppr ty2 <+> dcolon <+> ppr (typeKind  ty2)+              , ppr (isReflCo co_k), ppr co_k ]++       ; if isReflCo co_k+           -- Only proceed if the kinds match+           -- NB: tv1 should still be unfilled, despite the kind unification+           --     because tv1 is not free in ty2' (or, hence, in its kind)+         then do { liftZonkM $ writeMetaTyVar tv1 ty2+                 ; case u_unified env of+                     Nothing -> return ()+                     Just uref -> updTcRef uref (tv1 :)+                 ; return (mkNomReflCo ty2) }  -- Unification is always Nominal++         else -- The kinds don't match yet, so defer instead.+              do { writeTcRef def_eq_ref def_eqs+                     -- Since we are discarding co_k, also discard any constraints+                     -- emitted by kind unification; they are just useless clutter.+                     -- Do this dicarding by simply restoring the previous state+                     -- of def_eqs; a bit imperative/yukky but works fine.+                 ; defer }+         }}+  where+    ty1 = mkTyVarTy tv1+    defer = unSwap swapped (uType_defer env) ty1 ty2++    not_ok_so_defer cur_lvl =+      do { traceTc "uUnfilledVar2 not ok" $+             vcat [ text "tv1:" <+> ppr tv1+                  , text "ty2:" <+> ppr ty2+                  , text "simple-unify-chk:" <+> ppr (simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2)+                  ]+               -- Occurs check or an untouchable: just defer+               -- NB: occurs check isn't necessarily fatal:+               --     eg tv1 occurred in type family parameter+          ; defer }++swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool+swapOverTyVars is_given tv1 tv2+  -- See Note [Unification variables on the left]+  | not is_given, pri1 == 0, pri2 > 0 = True+  | not is_given, pri2 == 0, pri1 > 0 = False++  -- Level comparison: see Note [TyVar/TyVar orientation]+  | lvl1 `strictlyDeeperThan` lvl2 = False+  | lvl2 `strictlyDeeperThan` lvl1 = True++  -- Priority: see Note [TyVar/TyVar orientation]+  | pri1 > pri2 = False+  | pri2 > pri1 = True++  -- Names: see Note [TyVar/TyVar orientation]+  | isSystemName tv2_name, not (isSystemName tv1_name) = True++  | otherwise = False++  where+    lvl1 = tcTyVarLevel tv1+    lvl2 = tcTyVarLevel tv2+    pri1 = lhsPriority tv1+    pri2 = lhsPriority tv2+    tv1_name = Var.varName tv1+    tv2_name = Var.varName tv2+++lhsPriority :: TcTyVar -> Int+-- Higher => more important to be on the LHS+--        => more likely to be eliminated+-- Only used when the levels are identical+-- See Note [TyVar/TyVar orientation]+lhsPriority tv+  = assertPpr (isTyVar tv) (ppr tv) $+    case tcTyVarDetails tv of+      RuntimeUnk  -> 0+      SkolemTv {} -> 0+      MetaTv { mtv_info = info, mtv_tclvl = lvl }+        | QLInstVar <- lvl+        -> 5  -- Eliminate instantiation variables first+        | otherwise+        -> case info of+             CycleBreakerTv -> 0+             TyVarTv        -> 1+             ConcreteTv {}  -> 2+             TauTv          -> 3+             RuntimeUnkTv   -> 4++{- Note [Unification preconditions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Question: given a homogeneous equality (alpha ~# ty), when is it OK to+unify alpha := ty?+(This note only applies to /homogeneous/ equalities, in which both+sides have the same kind.)++There are five reasons not to unify:++1. (SKOL-ESC) Skolem-escape+   Consider the constraint+        forall[2] a[2]. alpha[1] ~ Maybe a[2]+   If we unify alpha := Maybe a, the skolem 'a' may escape its scope.+   The level alpha[1] says that alpha may be used outside this constraint,+   where 'a' is not in scope at all.  So we must not unify.++   Bottom line: when looking at a constraint alpha[n] := ty, do not unify+   if any free variable of 'ty' has level deeper (greater) than n++2. (UNTOUCHABLE) Untouchable unification variables+   Consider the constraint+        forall[2] a[2]. b[1] ~ Int => alpha[1] ~ Int+   There is no (SKOL-ESC) problem with unifying alpha := Int, but it might+   not be the principal solution. Perhaps the "right" solution is alpha := b.+   We simply can't tell.  See "OutsideIn(X): modular type inference with local+   assumptions", section 2.2.  We say that alpha[1] is "untouchable" inside+   this implication.++   Bottom line: at ambient level 'l', when looking at a constraint+   alpha[n] ~ ty, do not unify alpha := ty if there are any given equalities+   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.InertSet++3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs+   This precondition looks at the MetaInfo of the unification variable:++   * TyVarTv: When considering alpha{tyv} ~ ty, if alpha{tyv} is a+     TyVarTv it can only unify with a type variable, not with a+     structured type.  So if 'ty' is a structured type, such as (Maybe x),+     don't unify.++   * CycleBreakerTv: never unified, except by restoreTyVarCycles.++4. (CONCRETE) A ConcreteTv can only unify with a concrete type,+    by definition.++    That is, if we have `rr[conc] ~ F Int`, we can't unify+    `rr` with `F Int`, so we hold off on unifying.+    Note however that the equality might get rewritten; for instance+    if we can rewrite `F Int` to a concrete type, say `FloatRep`,+    then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`.++    Note that we can still make progress on unification even if+    we can't fully solve an equality, e.g.++      alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ]++    we can fill beta[tau] := beta[conc]. This is why we call+    'makeTypeConcrete' in startSolvingByUnification.++5. (REWRITERS) the equality does not have any unsolved equalities in its rewriter+   set. If those other equalities have not been solved, unifying this equality+   will propagate strange-looking errors elswhere.  That is the whole point of+   rewriter sets.  Suppose our equality is+     [W] co1 {rew = {cok}}   (alpha :: k) ~ (Int |> {cok})+   where co :: Type ~ k is an unsolved wanted. Note that this equality+   is homogeneous; both sides have kind k. We refrain from unifying+   here, because of `cok` in its rewriter set.  See+   Note [Unify only if the rewriter set is empty] in GHC.Solver.Equality.++Needless to say, all there are wrinkles:++* (SKOL-ESC) Promotion.  Given alpha[n] ~ ty, what if beta[k] is free+  in 'ty', where beta is a unification variable, and k>n?  'beta'+  stands for a monotype, and since it is part of a level-n type+  (equal to alpha[n]), we must /promote/ beta to level n.  Just make+  up a fresh gamma[n], and unify beta[k] := gamma[n].++* (TYVAR-TV) Unification variables.  Suppose alpha[tyv,n] is a level-n+  TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now+  consider alpha[tyv,n] ~ Bool.  We don't want to unify because that+  would break the TyVarTv invariant.++  What about alpha[tyv,n] ~ beta[tau,n], where beta is an ordinary+  TauTv?  Again, don't unify, because beta might later be unified+  with, say Bool.  (If levels permit, we reverse the orientation here;+  see Note [TyVar/TyVar orientation].)++* (UNTOUCHABLE) Untouchability.  When considering (alpha[n] ~ ty), how+  do we know whether there are any given equalities between level n+  and the ambient level?  We answer in two ways:++  * In the eager unifier, we only unify if l=n.  If not, alpha may be+    untouchable, and defer to the constraint solver.  This check is+    made in GHC.Tc.Utils.uUnifilledVar2, in the guard+    isTouchableMetaTyVar.++  * In the constraint solver, we track where Given equalities occur+    and use that to guard unification in+    GHC.Tc.Utils.Unify.touchabilityTest. 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+    implication in a separate step, so that they would become touchable.+    But the float/don't-float question turned out to be very delicate,+    as you can see if you look at the long series of Notes associated with+    GHC.Tc.Solver.floatEqualities, around Nov 2020.  It's much easier+    to unify in-place, with no floating.++Note [TyVar/TyVar orientation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Fundeps with instances, and equality orientation]+where the kind equality orientation is important++Given (a ~ b), should we orient the equality as (a~b) or (b~a)?+This is a surprisingly tricky question!++The question is answered by swapOverTyVars, which is used+  - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1+  - in the constraint solver, in GHC.Tc.Solver.Equality.canEqCanLHS2++First note: only swap if you have to!+   See Note [Avoid unnecessary swaps]++So we look for a positive reason to swap, using a three-step test:++* Level comparison. If 'a' has deeper level than 'b',+  put 'a' on the left.  See Note [Deeper level on the left]++* Priority.  If the levels are the same, look at what kind of+  type variable it is, using 'lhsPriority'.++  Generally speaking we always try to put a MetaTv on the left in+  preference to SkolemTv or RuntimeUnkTv, because the MetaTv may be+  touchable and can be unified.++  Tie-breaking rules for MetaTvs:+  - CycleBreakerTv: This is essentially a stand-in for another type;+       it's untouchable and should have the same priority as a skolem: 0.++  - TyVarTv: These can unify only with another tyvar, but we can't unify+       a TyVarTv with a TauTv, because then the TyVarTv could (transitively)+       get a non-tyvar type. So give these a low priority: 1.++  - ConcreteTv: These are like TauTv, except they can only unify with+    a concrete type. So we want to be able to write to them, but not quite+    as much as TauTvs: 2.++  - TauTv: This is the common case; we want these on the left so that they+       can be written to: 3.++  - RuntimeUnkTv: These aren't really meta-variables used in type inference,+       but just a convenience in the implementation of the GHCi debugger.+       Eagerly write to these: 4. See Note [RuntimeUnkTv] in+       GHC.Runtime.Heap.Inspect.++* Names. If the level and priority comparisons are all+  equal, try to eliminate a TyVar with a System Name in+  favour of ones with a Name derived from a user type signature++* Age.  At one point in the past we tried to break any remaining+  ties by eliminating the younger type variable, based on their+  Uniques.  See Note [Eliminate younger unification variables]+  (which also explains why we don't do this any more)++Note [Unification variables on the left]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of+level, so that the unification variable is on the left.++* We /don't/ want this for Givens because if we ave+    [G] a[2] ~ alpha[1]+    [W] Bool ~ a[2]+  we want to rewrite the wanted to Bool ~ alpha[1],+  so we can float the constraint and solve it.++* But for Wanteds putting the unification variable on+  the left means an easier job when floating, and when+  reporting errors -- just fewer cases to consider.++  In particular, we get better skolem-escape messages:+  see #18114++Note [Deeper level on the left]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The most important thing is that we want to put tyvars with+the deepest level on the left.  The reason to do so differs for+Wanteds and Givens, but either way, deepest wins!  Simple.++* Wanteds.  Putting the deepest variable on the left maximise the+  chances that it's a touchable meta-tyvar which can be solved.++* Givens. Suppose we have something like+     forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]++  If we orient the Given a[2] on the left, we'll rewrite the Wanted to+  (beta[1] ~ b[1]), and that can float out of the implication.+  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.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+  skolems, so it's important that skolems have (accurate) level+  numbers.++See #15009 for an further analysis of why "deepest on the left"+is a good plan.++Note [Avoid unnecessary swaps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we swap without actually improving matters, we can get an infinite loop.+Consider+    work item:  a ~ b+   inert item:  b ~ c+We canonicalise the work-item to (a ~ c).  If we then swap it before+adding to the inert set, we'll add (c ~ a), and therefore kick out the+inert guy, so we get+   new work item:  b ~ c+   inert item:     c ~ a+And now the cycle just repeats++Historical Note [Eliminate younger unification variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a choice of unifying+     alpha := beta   or   beta := alpha+we try, if possible, to eliminate the "younger" one, as determined+by `ltUnique`.  Reason: the younger one is less likely to appear free in+an existing inert constraint, and hence we are less likely to be forced+into kicking out and rewriting inert constraints.++This is a performance optimisation only.  It turns out to fix+#14723 all by itself, but clearly not reliably so!++It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).+But, to my surprise, it didn't seem to make any significant difference+to the compiler's performance, so I didn't take it any further.  Still+it seemed too nice to discard altogether, so I'm leaving these+notes.  SLPJ Jan 18.++Note [Prevent unification with type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prevent unification with type families because of an uneasy compromise.+It's perfectly sound to unify with type families, and it even improves the+error messages in the testsuite. It also modestly improves performance, at+least in some cases. But it's disastrous for test case perf/compiler/T3064.+Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.+What do we do? Do we reduce F? Or do we use the given? Hard to know what's+best. GHC reduces. This is a disaster for T3064, where the type's size+spirals out of control during reduction. If we prevent+unification with type families, then the solver happens to use the equality+before expanding the type family.++It would be lovely in the future to revisit this problem and remove this+extra, unnecessary check. But we retain it for now as it seems to work+better in practice.++Revisited in Nov '20, along with removing flattening variables. Problem+is still present, and the solution is still the same.++Note [Non-TcTyVars in GHC.Tc.Utils.Unify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because the same code is now shared between unifying types and unifying+kinds, we sometimes will see proper TyVars floating around the unifier.+Example (from test case polykinds/PolyKinds12):++    type family Apply (f :: k1 -> k2) (x :: k1) :: k2+    type instance Apply g y = g y++When checking the instance declaration, we first *kind-check* the LHS+and RHS, discovering that the instance really should be++    type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y++During this kind-checking, all the tyvars will be TcTyVars. Then, however,+as a second pass, we desugar the RHS (which is done in functions prefixed+with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper+TyVars, not TcTyVars, get some kind unification must happen.++Thus, we always check if a TyVar is a TcTyVar before asking if it's a+meta-tyvar.++This used to not be necessary for type-checking (that is, before * :: *)+because expressions get desugared via an algorithm separate from+type-checking (with wrappers, etc.). Types get desugared very differently,+causing this wibble in behavior seen here.+-}++-- | Breaks apart a function kind into its pieces.+matchExpectedFunKind+  :: TypedThing     -- ^ type, only for errors+  -> Arity           -- ^ n: number of desired arrows+  -> TcKind          -- ^ fun_kind+  -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)++matchExpectedFunKind hs_ty n k = go n k+  where+    go 0 k = return (mkNomReflCo k)++    go n k | Just k' <- coreView k = go n k'++    go n k@(TyVarTy kvar)+      | isMetaTyVar kvar+      = do { maybe_kind <- readMetaTyVar kvar+           ; case maybe_kind of+                Indirect fun_kind -> go n fun_kind+                Flexi ->             defer n k }++    go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })+      | isVisibleFunArg af+      = do { co <- go (n-1) res+           ; return (mkNakedFunCo Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) }++    go n other+     = defer n other++    defer n k+      = do { arg_kinds <- newMetaKindVars n+           ; res_kind  <- newMetaKindVar+           ; let new_fun = mkVisFunTysMany arg_kinds res_kind+                 origin  = TypeEqOrigin { uo_actual   = k+                                        , uo_expected = new_fun+                                        , uo_thing    = Just hs_ty+                                        , uo_visible  = True+                                        }+           ; unifyTypeAndEmit KindLevel origin k new_fun }++{- *********************************************************************+*                                                                      *+                 Checking alpha ~ ty+              for the on-the-fly unifier+*                                                                      *+********************************************************************* -}++data UnifyCheckCaller+  = UC_OnTheFly   -- Called from the on-the-fly unifier+  | UC_QuickLook  -- Called from Quick Look+  | UC_Solver     -- Called from constraint solver++-- | The result type of 'simpleUnifyCheck'.+data SimpleUnifyResult+  -- | Definitely cannot unify (untouchable variable or incompatible top-shape)+  = SUC_CannotUnify+  -- | The variable is touchable and the top-shape test passed, but+  -- it may or may not be OK to unify+  | SUC_NotSure+  -- | Definitely OK to unify+  | SUC_CanUnify+  deriving stock (Eq, Ord, Show)+instance Semigroup SimpleUnifyResult where+  no@SUC_CannotUnify <> _ = no+  SUC_CanUnify <> r = r+  _ <> no@SUC_CannotUnify = no+  r <> SUC_CanUnify = r+  ns@SUC_NotSure <> SUC_NotSure = ns++instance Outputable SimpleUnifyResult where+  ppr = \case+    SUC_CannotUnify -> text "SUC_CannotUnify"+    SUC_NotSure     -> text "SUC_NotSure"+    SUC_CanUnify    -> text "SUC_CanUnify"++simpleUnifyCheck :: UnifyCheckCaller -> TcLevel -> TcTyVar -> TcType -> SimpleUnifyResult+-- ^ A fast check for unification. May return "not sure", in which case+-- unification might still be OK, but it'll take more work to do+-- (use the full 'checkTypeEq').+--+-- * Rejects if lhs_tv occurs in rhs_ty (occurs check)+-- * Rejects foralls unless+--      lhs_tv is RuntimeUnk (used by GHCi debugger)+--          or is a QL instantiation variable+-- * Rejects a non-concrete type if lhs_tv is concrete+-- * Rejects type families unless fam_ok=True+-- * Does a level-check for type variables, to avoid skolem escape+--+-- This function is pretty heavily used, so it's optimised not to allocate+simpleUnifyCheck caller given_eq_lvl lhs_tv rhs+  | not $ touchabilityTest given_eq_lvl lhs_tv+  = SUC_CannotUnify+  | not $ checkTopShape lhs_info rhs+  = SUC_CannotUnify+  | rhs_is_ok rhs+  = SUC_CanUnify+  | otherwise+  = SUC_NotSure+  where+    lhs_info = metaTyVarInfo lhs_tv++    !(occ_in_ty, occ_in_co) = mkOccFolders (tyVarName lhs_tv)++    lhs_tv_lvl         = tcTyVarLevel lhs_tv+    lhs_tv_is_concrete = isConcreteTyVar lhs_tv++    forall_ok = case caller of+                   UC_QuickLook -> isQLInstTyVar lhs_tv+                   _            -> isRuntimeUnkTyVar lhs_tv++    -- This fam_ok thing relates to a very specific perf problem+    -- See Note [Prevent unification with type families]+    -- A couple of QuickLook regression tests rely on unifying with type+    --   families, so we let it through there (not very principled, but let's+    --   see if it bites us)+    fam_ok = case caller of+               UC_Solver     -> True+               UC_QuickLook  -> True+               UC_OnTheFly   -> False++    rhs_is_ok (TyVarTy tv)+      | lhs_tv == tv                                    = False+      | tcTyVarLevel tv `strictlyDeeperThan` lhs_tv_lvl = False+      | lhs_tv_is_concrete, not (isConcreteTyVar tv)    = False+      | occ_in_ty $! (tyVarKind tv)                     = False+      | otherwise                                       = True++    rhs_is_ok (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})+      | not forall_ok, isInvisibleFunArg af = False+      | otherwise                           = rhs_is_ok w && rhs_is_ok a && rhs_is_ok r++    rhs_is_ok (TyConApp tc tys)+      | lhs_tv_is_concrete, not (isConcreteTyCon tc) = False+      | not forall_ok, not (isTauTyCon tc)           = False+      | not fam_ok,    not (isFamFreeTyCon tc)       = False+      | otherwise                                    = all rhs_is_ok tys++    rhs_is_ok (ForAllTy (Bndr tv _) ty)+      | forall_ok = rhs_is_ok (tyVarKind tv) && (tv == lhs_tv || rhs_is_ok ty)+      | otherwise = False++    rhs_is_ok (AppTy t1 t2)    = rhs_is_ok t1 && rhs_is_ok t2+    rhs_is_ok (CastTy ty co)   = not (occ_in_co co) && rhs_is_ok ty+    rhs_is_ok (CoercionTy co)  = not (occ_in_co co)+    rhs_is_ok (LitTy {})       = True+++mkOccFolders :: Name -> (TcType -> Bool, TcCoercion -> Bool)+-- These functions return True+--   * if lhs_tv occurs (incl deeply, in the kind of variable)+--   * if there is a coercion hole+-- No expansion of type synonyms+mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co)+  where+    !(check_ty, _, check_co, _) = foldTyCo occ_folder emptyVarSet+    occ_folder = TyCoFolder { tcf_view  = noView  -- Don't expand synonyms+                            , tcf_tyvar = do_tcv, tcf_covar = do_tcv+                            , tcf_hole  = do_hole+                            , tcf_tycobinder = do_bndr }++    do_tcv is v = Any (not (v `elemVarSet` is) && tyVarName v == lhs_tv)+                  `mappend` check_ty (varType v)++    do_bndr is tcv _faf = extendVarSet is tcv+    do_hole _is _hole = DM.Any True  -- Reject coercion holes++{- *********************************************************************+*                                                                      *+                 Equality invariant checking+*                                                                      *+********************************************************************* -}+++{-  Note [Checking for foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We never want to unify+    alpha ~ (forall a. a->a) -> Int+So we look for foralls hidden inside the type, and it's convenient+to do that at the same time as the occurs check (which looks for+occurrences of alpha).++However, it's not just a question of looking for foralls /anywhere/!+Consider+   (alpha :: forall k. k->*)  ~  (beta :: forall k. k->*)+This is legal; e.g. dependent/should_compile/T11635.++We don't want to reject it because of the forall in beta's kind, but+(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type)+we do need to look in beta's kind.  So we carry a flag saying if a+'forall' is OK, and switch the flag on when stepping inside a kind.++Why is it OK?  Why does it not count as impredicative polymorphism?+The reason foralls are bad is because we reply on "seeing" foralls+when doing implicit instantiation.  But the forall inside the kind is+fine.  We'll generate a kind equality constraint+  (forall k. k->*) ~ (forall k. k->*)+to check that the kinds of lhs and rhs are compatible.  If alpha's+kind had instead been+  (alpha :: kappa)+then this kind equality would rightly complain about unifying kappa+with (forall k. k->*)++Note [Forgetful synonyms in checkTyConApp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   type S a b = b   -- Forgets 'a'++   [W] alpha[2] ~ Maybe (S beta[4] gamma[2])++We don't want to promote beta to level 2; rather, we should+expand the synonym. (Currently, in checkTypeEqRhs promotion+is irrevocable, by side effect.)++To avoid this risk we eagerly expand forgetful synonyms.+This also means we won't get an occurs check in+   a ~ Maybe (S a b)++The annoyance is that we might expand the synonym unnecessarily,+something we generally try to avoid.  But for now, this seems+simple.++In a forgetful case like a ~ Maybe (S a b), `checkTyEqRhs` returns+a Reduction that looks+    Reduction { reductionCoercion    = Refl+              , reductionReducedType = Maybe b }+We must jolly well use that reductionReduced type, even though the+reductionCoercion is Refl.  See `canEqCanLHSFinish_no_unification`.+-}++data PuResult a b+  -- | Pure unifier failure.+  --+  -- Invariant: the CheckTyEqResult is not 'cteOK'; that it, it specifies a problem.+  = PuFail CheckTyEqResult+  -- | Pure unifier success.+  | PuOK (Bag a) b+  deriving stock (Functor, Foldable, Traversable)++instance Applicative (PuResult a) where+  pure x = PuOK emptyBag x+  PuFail p1 <*> PuFail p2 = PuFail (p1 S.<> p2)+  PuFail p1 <*> PuOK {}   = PuFail p1+  PuOK {}   <*> PuFail p2 = PuFail p2+  PuOK c1 f <*> PuOK c2 x = PuOK (c1 `unionBags` c2) (f x)++instance (Outputable a, Outputable b) => Outputable (PuResult a b) where+  ppr (PuFail prob) = text "PuFail" <+> (ppr prob)+  ppr (PuOK cts x)  = text "PuOK" <> braces+                        (vcat [ text "redn:" <+> ppr x+                              , text "cts:" <+> ppr cts ])++okCheckRefl :: TcType -> PuResult a Reduction+okCheckRefl ty = PuOK emptyBag (mkReflRedn Nominal ty)++mapCheck :: Monad m+         => (x -> m (PuResult a Reduction))+         -> [x]+         -> m (PuResult a Reductions)+mapCheck f xs+  = do { (ress :: [PuResult a Reduction]) <- mapM f xs+       ; return (unzipRedns <$> sequenceA ress) }+         -- sequenceA :: [PuResult a Reduction] -> PuResult a [Reduction]+         -- unzipRedns :: [Reduction] -> Reductions+{-# INLINEABLE mapCheck #-}++-----------------------------+-- | Options describing how to deal with a type equality+-- in the eager unifier. See 'checkTyEqRhs'+data TyEqFlags m a+  = -- | TFTyFam: LHS is a type family application+    -- Invariant: we are not unifying; see `notUnifying_TEFTask`+    TEFTyFam+    { tefTyFam_occursCheck :: CheckTyEqProblem+       -- ^ The 'CheckTyEqProblem' to report for occurs-check failures+       -- (soluble or insoluble)+    , tefTyFam_tyCon :: TyCon+    , tefTyFam_args  :: [Type]+    , tef_fam_app :: TyEqFamApp m a+        -- ^ How to deal with type family applications+    }++  -- | TEFTyVar: LHS is a 'TyVar'.+  | TEFTyVar+    -- NB: this constructor does not actually store a 'TyVar', in order to+    -- support being called from 'makeTypeConcrete' (which works as if we+    -- created a fresh 'ConcreteTv' metavariable; see (3) in Note [TyEqFlags])+    { tefTyVar_occursCheck    :: OccursCheck+        -- ^ Occurs check+    , tefTyVar_levelCheck     :: LevelCheck m+        -- ^ Level check+    , tefTyVar_concreteCheck  :: ConcreteCheck m+        -- ^ Concreteness check+    , tef_fam_app :: TyEqFamApp m a+        -- ^ How to deal with type family applications+    }++-- | What to do when encountering a type-family application while processing+-- a type equality in the pure unifier.+--+-- See Note [Family applications in canonical constraints]+data TyEqFamApp m a where+  -- | Just recurse+  TEFA_Recurse     :: TyEqFamApp m a+  -- | Recurse, but replace with cycle breaker if that fails,+  -- using the specified 'FamAppBreaker'+  TEFA_Break       :: FamAppBreaker a -> TyEqFamApp TcM a++-- | A defunctionalisation of family application breaker functions.+--     Interpreter: `famAppBreaker`+data FamAppBreaker a where+  BreakGiven  :: FamAppBreaker (TcTyVar, TcType)+  BreakWanted :: CtEvidence -> TcTyVar -> FamAppBreaker Ct++data OccursCheck where+  -- | No occurs check.+  OC_None :: OccursCheck+  -- | Do an occurs check between the LHS tyvar and the RHS.+  OC_Check ::+    { occurs_tv_name :: Name+      -- ^ The 'Name' to perform an occurs-check on+    , occurs_problem :: CheckTyEqProblem+      -- ^ Which 'CheckTyEqProblem' to report for occurs-check failures+      -- (soluble or insoluble)+    } -> OccursCheck++-- | What level check to perform, in a call to the pure unifier?+-- A defunctionalisation of the possible level-check functions+--   Interpreter: `tyVarLevelCheck`+data LevelCheck m where+  -- | No level check.+  LC_None :: LevelCheck m+  -- | Do a level check between the LHS tyvar and the occurrence tyvar.+  --+  -- Fail if the level check fails.+  --+  -- True <=> lenient check, e.g. the levels have a chance of working out+  -- after promotion.+  LC_Check ::+    { lc_lvlc    :: TcLevel+    , lc_lenient :: Bool+    } -> LevelCheck m++  -- | Do a level check between the LHS tyvar and the occurrence tyvar.+  --+  -- If the level check fails, and the occurrence is a unification+  -- variable, promote it.+  --+  --   - False <=> don't promote under type families (the common case)+  --   -  True <=> promote even under type families+  --             (see Note [Defaulting equalities] in GHC.Tc.Solver)+  LC_Promote+    :: { lc_lvlp :: TcLevel+       , lc_deep :: Bool+       } -> LevelCheck TcM++data ConcreteCheck m where+  -- | No concreteness check.+  CC_None :: ConcreteCheck m+  -- | Simple check for concreteness, leniently returning 'OK'+  -- if concreteness could be achieved after promotion.+  CC_Check :: ConcreteCheck m+  -- | Proper concreteness check: promote non-concrete metavariables,+  -- failing if there are any problems.+  CC_Promote :: ConcreteTvOrigin -> ConcreteCheck TcM++{- Note [TyEqFlags]+~~~~~~~~~~~~~~~~~~~+When we call the eager unifier, e.g. through 'checkTyEqRhs', we specify what+kind of checks the unifier performs via the 'TyEqFlags' argument. In particular,+when the LHS type in a unification is a type variable, we might want to perform+different checks; this is achieved using the 'TEFTyVar' constructor to 'TyEqFlags':++  1. `notUnifying_TEFTask`+     LHS is a skolem tyvar, or an untouchable meta-tyvar.+     We are not unifying; we only want to perform occurs-checks.++      TEFTyVar+        { tefTyVar_occursCheck   = OC_Check ...+        , tefTyVar_levelCheck    = LC_None+        , tefTyVar_concreteCheck = CC_None+        , tef_fam_app            = TEFA_Recurse+        }++  2a. `unifyingLHSMetaTyVar_TEFTask`+     We are unifying; we want to perform an occurs check, a level check,+     and a concreteness check (when the meta-tyvar is a ConcreteTv).++      TEFTyVar+        { tefTyVar_occursCheck   = OC_Check ...+        , tefTyVar_levelCheck    = LC_Promote ...+        , tefTyVar_concreteCheck = CC_Promote or CC_None+            -- depending on whether or not the lhs tv is concrete+        , tef_fam_app            = TEFA_Recurse+        }++  2b. `defaulting_TEFTask`+     We are in the top-level defaulting code, considering unifying a+     touchable meta-tyvar with a type.++      TEFTyVar+        { tefTyVar_occursCheck   = OC_None+        , tefTyVar_levelCheck    = LC_None+        , tefTyVar_concreteCheck = CC_Promote or CC_None+            -- depending on whether or not the lhs tv is concrete+        , tef_fam_app            = TEFA_Recurse+        }++  3. `makeTypeConcrete`+     LHS is a fresh ConcreteTv meta-tyvar (see call to 'checkTyEqRhs' in+     `makeTypeConcrete`). We are unifying; we only want to perform+     a concreteness check.++      TEFTyVar+        { tefTyVar_occursCheck   = OC_None+        , tefTyVar_levelCheck    = LC_None+        , tefTyVar_concreteCheck = CC_Promote conc_orig+        , tef_fam_app            = TEFA_Recurse+        }++  4. `pureTyEqFlags_LHSMetaTyVar`+     We want to perform a non-monadic check, i.e. we want to know whether we are able+     to unify 'lhs_tv' with 'rhs_ty', but don't want to actually perform+     a side-effecting unification. This is used in 'mightEqualLater'.++      TEFTyVar+        { tefTyVar_occursCheck   = OC_Check ...+        , tefTyVar_levelCheck    = LC_Check ...+        , tefTyVar_concreteCheck = CC_Check or CC_None+            -- depending on whether or not the lhs tv is concrete+        , tef_fam_app            = TEFA_Recurse+        }++     Here 'LC_Check True' and 'ConcreteSimpleCheck' make 'checkTyEqRhs' perform+     conservative pure checks, without actually carrying out any promotion.+-}++-- | Create a "not unifying" 'TyEqFlags' from a 'CanEqLHS'.+--+-- See use-case (1) in Note [TyEqFlags].+notUnifying_TEFTask :: CheckTyEqProblem -> CanEqLHS -> TyEqFlags m a+notUnifying_TEFTask occ_prob = \case+  TyFamLHS tc tys ->+    TEFTyFam+      { tefTyFam_tyCon = tc+      , tefTyFam_args  = tys+      , tefTyFam_occursCheck = occ_prob+      , tef_fam_app = TEFA_Recurse+      }+  TyVarLHS tv ->+    TEFTyVar+      { tefTyVar_occursCheck   = OC_Check (tyVarName tv) occ_prob+      , tefTyVar_levelCheck    = LC_None+      , tefTyVar_concreteCheck = CC_None+      , tef_fam_app            = TEFA_Recurse+     }+    -- We need an occurs-check here, but no level check.+    -- See Note [Promotion and level-checking] wrinkle (W1)+    -- TEFA_Recurse: see Note [Don't cycle-break Wanteds when not unifying]++-- | Create "unifying" 'TyEqFlags' from a 'TyVarLHS'.+--+-- Invariant: the argument 'TcTyVar' is a 'MetaTv'.+unifyingLHSMetaTyVar_TEFTask :: CtEvidence -> TcTyVar -> TyEqFlags TcM Ct+unifyingLHSMetaTyVar_TEFTask ev lhs_tv =+  TEFTyVar+    { tefTyVar_occursCheck   = OC_Check (tyVarName lhs_tv) cteInsolubleOccurs+    , tefTyVar_levelCheck    = LC_Promote { lc_lvlp = tcTyVarLevel lhs_tv+                                          , lc_deep = False }+    , tefTyVar_concreteCheck = mkConcreteCheck lhs_tv+    , tef_fam_app            = mkTEFA_Break ev NomEq (BreakWanted ev lhs_tv)+    }++defaulting_TEFTask :: TcTyVar -> TyEqFlags TcM a+-- Used during top-level defauting in GHC.Tc.Solver.Default.defaultEquality+-- Invariant: the argument 'TcTyVar' is a 'MetaTv'.+defaulting_TEFTask lhs_tv =+  TEFTyVar+    { tefTyVar_occursCheck   = OC_Check (tyVarName lhs_tv) cteInsolubleOccurs+    , tefTyVar_levelCheck    = LC_Promote { lc_lvlp = tcTyVarLevel lhs_tv+                                          , lc_deep = True }+              -- LC_Promote: promote deeper unification variables (DE4)+              -- lc_deep =  True: ...including under type families (DE5)+    , tefTyVar_concreteCheck = mkConcreteCheck lhs_tv+    , tef_fam_app = TEFA_Recurse+    }++mkConcreteCheck :: TcTyVar -> ConcreteCheck TcM+mkConcreteCheck lhs_tv = case isConcreteTyVar_maybe lhs_tv of+                           Nothing        -> CC_None+                           Just conc_orig -> CC_Promote conc_orig++-- | 'TyEqFlags' for a pure call of 'checkTyEqRhs'.+--+-- A call to 'checkTyEqRhs' with these 'TyEqFlags' will perform an optimistic+-- check: it will return 'PuFail' if there is definitely a problem, but it+-- might return 'PuOK' if it isn't entirely sure.+pureTyEqFlags_LHSMetaTyVar :: TyVar -> TyEqFlags Identity ()+pureTyEqFlags_LHSMetaTyVar lhs_tv =+  TEFTyVar+    { tefTyVar_occursCheck   = OC_Check (tyVarName lhs_tv) cteInsolubleOccurs+    , tefTyVar_levelCheck    = LC_Check { lc_lvlc = tcTyVarLevel lhs_tv+                                        , lc_lenient = True }+    , tefTyVar_concreteCheck = case isConcreteTyVar_maybe lhs_tv of+                                  Nothing -> CC_None+                                  Just {} -> CC_Check   -- No promotion+    , tef_fam_app = TEFA_Recurse }+++mkTEFA_Break :: CtEvidence -> EqRel -> FamAppBreaker a -> TyEqFamApp TcM a+mkTEFA_Break ev eq_rel breaker+  | NomEq <- eq_rel+  , not cycle_breaker_origin+  = TEFA_Break breaker+  | otherwise+  = TEFA_Recurse+  where+    -- cycle_breaker_origin: see Detail (7) of Note [Type equality cycles]+    -- in GHC.Tc.Solver.Equality+    cycle_breaker_origin = case ctLocOrigin (ctEvLoc ev) of+                              CycleBreakerOrigin {} -> True+                              _                     -> False++-- | Do we want to perform a concreteness check in 'checkTyEqRhs'?+tefConcrete :: TyEqFlags m a -> Bool+tefConcrete (TEFTyFam {}) = False+tefConcrete (TEFTyVar { tefTyVar_concreteCheck = conc }) =+  wantConcreteCheck conc++wantConcreteCheck :: ConcreteCheck m -> Bool+wantConcreteCheck = \case+    CC_None -> False+    CC_Check -> True+    CC_Promote {} -> True++-- | Given a family-application @ty@, return a @'Reduction' :: ty ~ cbv@+-- where @cbv@ is a fresh loop-breaker tyvar (for Given), or+-- just a fresh 'TauTv' (for Wanted)+famAppBreaker :: FamAppBreaker a -> TcType -> TcM (PuResult a Reduction)+famAppBreaker BreakGiven fam_app+   = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app)+        ; return (PuOK (unitBag (new_tv, fam_app))+                       (mkReflRedn Nominal (mkTyVarTy new_tv))) }+                 -- Why reflexive? See Detail (4) of Note [Type equality cycles]+                 -- in GHC.Tc.Solver.Equality+famAppBreaker (BreakWanted ev lhs_tv) fam_app+  -- Occurs check or skolem escape; so flatten+  = do { reason <- checkPromoteFreeVars cteInsolubleOccurs+                     (tyVarName lhs_tv) lhs_tv_lvl+                     (tyCoVarsOfType fam_app_kind)+       ; if not (cterHasNoProblem reason)  -- Failed to promote free vars+         then return $ PuFail reason+         else+    do { new_tv_ty <-+          case lhs_tv_info of+            ConcreteTv conc_info ->+              -- Make a concrete tyvar if lhs_tv is concrete+              -- e.g.  alpha[2,conc] ~ Maybe (F beta[4])+              --       We want to flatten to+              --       alpha[2,conc] ~ Maybe gamma[2,conc]+              --       gamma[2,conc] ~ F beta[4]+              TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind+            _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind++       ; let pty = mkNomEqPred fam_app new_tv_ty+       ; hole <- TcM.newCoercionHole pty+       ; let new_ev = WantedCt { ctev_pred      = pty+                               , ctev_dest      = HoleDest hole+                               , ctev_loc       = cb_loc+                               , ctev_rewriters = ctEvRewriters ev }+       ; return (PuOK (singleCt (mkNonCanonical $ CtWanted new_ev))+                      (mkReduction (HoleCo hole) new_tv_ty)) } }+  where+    fam_app_kind = typeKind fam_app+    (lhs_tv_info, lhs_tv_lvl) =+      case tcTyVarDetails lhs_tv of+         MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info,lvl)+         -- lhs_tv should be a meta-tyvar+         _ -> pprPanic "famAppBreaker BreakWanted: lhs_tv is not a meta-tyvar"+                (ppr lhs_tv)+    cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin+      -- CycleBreakerOrigin: see Detail (7) of Note [Type equality cycles]++instance Outputable (TyEqFlags m a) where+  ppr = \case+    TEFTyFam occ tc tys fam_app ->+      text "TEFTyFam" <> braces (+        hcat [ ppr occ+             , ppr (mkTyConApp tc tys)+             , ppr fam_app ] )+    TEFTyVar occ lc conc fam_app ->+      text "TEFTyVar" <> braces (hcat (punctuate comma fields))+      where+        fields = [ text "OccursCheck:" <+> ppr occ ]+                   +++                 [ text "LevelCheck:" <+> ppr lc ]+                   +++                 [ text "ConcreteCheck:" <+> ppr conc ]+                   +++                 [ text "FamApp:" <+> ppr fam_app ]++instance Outputable (TyEqFamApp m a) where+  ppr TEFA_Recurse         = text "TEFA_Recurse"+  ppr (TEFA_Break breaker) = text "TEFA_BreakGiven" <+> ppr breaker++instance Outputable (FamAppBreaker a) where+  ppr BreakGiven          = text "BreakGiven"+  ppr (BreakWanted ev tv) = parens $ text "BreakWanted" <+> ppr ev <+> ppr tv++instance Outputable OccursCheck where+  ppr OC_None = text "OC_None"+  ppr (OC_Check { occurs_tv_name = nm }) = text "OC_Check" <+> ppr nm+instance Outputable (ConcreteCheck m) where+  ppr CC_None = text "CC_None"+  ppr CC_Check = text "CC_Check"+  ppr (CC_Promote {}) = text "CC_Promote"+instance Outputable (LevelCheck m) where+  ppr (LC_None) = text "LC_None"+  ppr (LC_Check lvl lenient) = text "LC_Check" <+> ppr lvl <+> ppWhen lenient (text "(lenient)")+  ppr (LC_Promote lvl deep)  = text "LC_Promote" <+> ppr lvl <+> ppWhen deep (text "(deep)")++-- | Adjust the 'TyEqFlags' when going under a type family:+--+--  1. Only the outer family application gets the loop-breaker treatment+--  2. Weaken level checks for tyvar promotion. For example, in @[W] alpha[2] ~ Maybe (F beta[3])@,+--     do not promote @beta[3]@, instead promote @(F beta[3])@.+--  3. Occurs checks become potentially soluble (after additional type family+--     reductions).+famAppArgFlags :: TyEqFlags m a -> TyEqFlags m a+famAppArgFlags flags = case flags of+  TEFTyFam {} ->+    flags+      { tef_fam_app = TEFA_Recurse -- (1)+      , tefTyFam_occursCheck = cteSolubleOccurs -- (3)+      }+  TEFTyVar { tefTyVar_occursCheck = occ, tefTyVar_levelCheck = mb_lc } ->+    flags+      { tef_fam_app = TEFA_Recurse -- (1)+      , tefTyVar_levelCheck = zap_lc mb_lc -- (2)+      , tefTyVar_occursCheck = soluble_occ occ -- (3)+      }+  where+    soluble_occ = \case+      OC_Check tv _ -> OC_Check tv cteSolubleOccurs+      OC_None -> OC_None+    zap_lc = \case+      LC_Promote { lc_lvlp = lvl, lc_deep = deeply }+        | not deeply+        -> LC_Check { lc_lvlc = lvl, lc_lenient = False }+      lc -> lc++{- Note [checkTyEqRhs]+~~~~~~~~~~~~~~~~~~~~~~+The key function `checkTyEqRhs ty_eq_flags rhs` is called on the+RHS of a type equality+       lhs ~ rhs+and checks to see if `rhs` satisfies, or can be made to satisfy,+invariants described by `ty_eq_flags`.  It can succeded or fail; in+the latter case it returns a `CheckTyEqResult` that describes why it+failed.++When `lhs` is a touchable type variable, so unification might happen, then+`checkTyEqRhs` enforces the unification preconditions of Note [Unification preconditions].++Notably, it can check for things like:+  * Insoluble occurs check+      e.g.  alpha[tau] ~ [alpha]+       or   F Int      ~ [F Int]+  * Potentially-soluble occurs check+      e.g.  alpha[tau] ~ [F alpha beta]+  * Impredicativity error:+      e.g.  alpha[tau] ~ (forall a. a->a)+  * Skolem escape+      e.g  alpha[1] ~ (b[sk:2], Int)+  * Concreteness error+      e.g. alpha[conc] ~ r[sk]++Its specific behaviour is governed by the `TyEqFlags` that are passed+to it; see Note [TyEqFlags].++Note, however, that `checkTyEqRhs` specifically does /not/ check for:+  * Touchability of the LHS (in the case of a unification variable)+  * Shape of the LHS (e.g. we can't unify Int with a TyVarTv)+These things are checked by `simpleUnifyCheck`.+-}+++-- | Perform the checks specified by the 'TyEqFlags' on the RHS, in order to+-- enforce the unification preconditions of Note [Unification preconditions].+--+-- See Note [checkTyEqRhs].+checkTyEqRhs :: forall m a+             .  Monad m+             => TyEqFlags m a+             -> TcType           -- Already zonked+             -> m (PuResult a Reduction)+checkTyEqRhs flags rhs+  -- Crucial special case for a top-level equality of the form 'alpha ~ F tys'.+  -- We don't want to flatten that (F tys), as this gets us right back to where+  -- we started!+  --+  -- See also Note [Special case for top-level of Given equality]+  | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs+  , not $ tefConcrete flags+  = recurseIntoFamTyConApp flags tc tys+  | otherwise+  = check_ty_eq_rhs flags rhs++{- Note [Special case for top-level of Given equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We take care when examining+    [G] F ty ~ G (...(F ty)...)+where both sides are TyFamLHSs.  We don't want to flatten that RHS to+    [G] F ty ~ cbv+    [G] G (...(F ty)...) ~ cbv+Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a+canonical constraint+    [G] G (...(F ty)...) ~ F ty+That tends to rewrite a big type to smaller one. This happens in T15703,+where we had:+    [G] Pure g ~ From1 (To1 (Pure g))+Making a loop breaker and rewriting left to right just makes much bigger+types than swapping it over.++(We might hope to have swapped it over before getting to checkTypeEq,+but better safe than sorry.)++NB: We never see a TyVarLHS here, such as+    [G] a ~ F tys here+because we'd have swapped it to+   [G] F tys ~ a+in canEqCanLHS2, before getting to checkTypeEq.+-}++check_ty_eq_rhs :: forall m a+                .  Monad m+                => TyEqFlags m a+                -> TcType           -- Already zonked+                -> m (PuResult a Reduction)+check_ty_eq_rhs flags ty+  = case ty of+      LitTy {}        -> return $ okCheckRefl ty+      TyConApp tc tys -> checkTyConApp flags ty tc tys+      TyVarTy tv      -> checkTyVar flags tv+        -- Don't worry about foralls inside the kind; see Note [Checking for foralls]+        -- Nor can we expand synonyms; see Note [Occurrence checking: look inside kinds]+        --                             in GHC.Core.FVs++      FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}+       | isInvisibleFunArg af  -- e.g.  Num a => blah+       -> return $ PuFail impredicativeProblem -- Not allowed (TyEq:F)+       | otherwise+       -> do { w_res <- check_ty_eq_rhs flags w+             ; a_res <- check_ty_eq_rhs flags a+             ; r_res <- check_ty_eq_rhs flags r+             ; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) }++      AppTy fun arg -> do { fun_res <- check_ty_eq_rhs flags fun+                          ; arg_res <- check_ty_eq_rhs flags arg+                          ; return (mkAppRedn <$> fun_res <*> arg_res) }++      CastTy ty co  -> do { ty_res <- check_ty_eq_rhs flags ty+                          ; co_res <- checkCo flags co+                          ; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) }++      CoercionTy co -> do { co_res <- checkCo flags co+                          ; return (mkReflCoRedn Nominal <$> co_res) }++      ForAllTy {}   -> return $ PuFail impredicativeProblem -- Not allowed (TyEq:F)+{-# INLINEABLE check_ty_eq_rhs #-}++-------------------+checkCo :: Monad m => TyEqFlags m a -> Coercion -> m (PuResult a Coercion)+-- See Note [checkCo]+checkCo flags co =+  case flags of+    TEFTyFam {} ->+      -- NB: 'TEFTyFam' case means we are not unifying.+      return (pure co)+    TEFTyVar+      { tefTyVar_concreteCheck = conc+      , tefTyVar_levelCheck    = lc+      , tefTyVar_occursCheck   = occ+      }+        -- Coercions cannot appear in concrete types.+        --+        -- See Note [Concrete types] in GHC.Tc.Utils.Concrete.+        | case conc of { CC_None -> False; _ -> True }+        -> return $ PuFail (cteProblem cteConcrete)++        -- Occurs check (can promote)+        | OC_Check lhs_tv occ_prob <- occ+        , LC_Promote { lc_lvlp = lhs_tv_lvl } <- lc+        -> do { reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfCo co)+              ; return $+                if cterHasNoProblem reason+                then pure co+                else PuFail reason }++        -- Occurs check (no promotion)+        | OC_Check lhs_tv occ_prob <- occ+        , nameUnique lhs_tv `elemVarSetByKey` tyCoVarsOfCo co+        -> return $ PuFail (cteProblem occ_prob)++        | otherwise+        -> return (pure co)++{- Note [checkCo]+~~~~~~~~~~~~~~~~~+We don't often care about the contents of coercions, so checking+coercions before making an equality constraint may be surprising.+But there are several cases we need to be wary of:++(1) When we're unifying a variable, we must make sure that the variable+    appears nowhere on the RHS -- even in a coercion. Otherwise, we'll+    create a loop.++(2) We must still make sure that no variable in a coercion is at too+    high a level. But, when unifying, we can promote any variables we encounter.++Note [Promotion and level-checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+"Promotion" happens when we have this:++  [W] w1: alpha[2] ~ Maybe beta[4]++Here we must NOT unify alpha := Maybe beta, because beta may turn out+to stand for a type involving some inner skolem.  Yikes!+Skolem-escape.  So instead we /promote/ beta, like this:++  beta[4] := beta'[2]+  [W] w1: alpha[2] ~ Maybe beta'[2]++Now we can unify alpha := Maybe beta', which might unlock other+constraints.  But if some other constraint wants to unify beta with a+nested skolem, it'll get stuck with a skolem-escape error.++Now consider `w2` where a type family is involved (#22194):++  [W] w2: alpha[2] ~ Maybe (F gamma beta[4])++In `w2`, it may or may not be the case that `beta` is level 2; suppose+we later discover gamma := Int, and type instance F Int _ = Int.+So, instead, we promote the entire funcion call:++  [W] w2': alpha[2] ~ Maybe gamma[2]+  [W] w3:  gamma[2] ~ F gamma beta[4]++Now we can unify alpha := Maybe gamma, which is a Good Thng.++Wrinkle (W1)++There is an important wrinkle: /all this only applies when unifying/.+For example, suppose we have+ [G] a[2] ~ Maybe b[4]+where 'a' is a skolem.  This Given might arise from a GADT match, and+we can absolutely use it to rewrite locally. In fact we must do so:+that is how we exploit local knowledge about the outer skolem a[2].+This applies equally for a Wanted [W] a[2] ~ Maybe b[4]. Using it for+local rewriting is fine. (It's not clear to me that it is /useful/,+but it's fine anyway.)++So we only do the level-check in checkTyVar when /unifying/ not for+skolems (or untouchable unification variables).++Note [Family applications in canonical constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A constraint with a type family application in the RHS needs special care.+This is dealt with by `checkFamApp`.++(CFA1) First, occurs checks.  If we have+     [G] a ~ Maybe (F (Maybe a))+     [W] alpha ~ Maybe (F (Maybe alpha))+  it looks as if we have an occurs check.  But go read+  Note [Type equality cycles] in GHC.Tc.Solver.Equality++  The same considerations apply when the LHS is a type family:+     [G] G a ~ Maybe (F (Maybe (G a)))+     [W] G alpha ~ Maybe (F (Maybe (G alpha)))++(CFA2) Second, promotion. If we have (#22194)+     [W] alpha[2] ~ Maybe (F beta[4])+  it is wrong to promote beta.  Instead we want to split to+     [W] alpha[2] ~ Maybe gamma[2]+     [W] gamma[2] ~ F beta[4]+  See Note [Promotion and level-checking] above.++(CFA3) Third, concrete type variables.  If we have+     [W] alpha[conc] ~ Maybe (F tys)+  we want to add an extra variable thus:+     [W] alpha[conc] ~ Maybe gamma[conc]+     [W] gamma[conc] ~ F tys+  Now we can unify alpha, and that might unlock something else.++In all these cases we want to create a fresh type variable, and+emit a new equality connecting it to the type family application.++Once these three cases are dealt with, the `tef_fam_app` field of `TypeEqFlags`+says what to do:++(CFA4) `TEFA_Recurse` is straightforward: just recurse into the arguments,+  BUT use `recurseIntoFamTyConApp` to record that we are now "under" a+  type-family application; see `famAppArgFlags`.++(CFA5) `TEFA_Break` is the clever one. It does a two-step process:++  (1) Recurse into the arguments with `recurseIntoFamTyConApp`.++  (2) If any of the arguments fail (level-check error, occurs check,+      concreteness failure), use the `FamAppBreaker` to create a cycle breaker.++  Remarks:++  * It would be possible to use Step (2) above always, skipping Step (1).+    But this would create many unnecessary cycle-breaker variables.+    This was the cause of #25933.++  * This always cycle-breaks the /outermost/ family application.+    If we have  [W] alpha ~ Maybe (F (G alpha)):+    - We'll use checkFamApp on `(F (G alpha))`+    - In Step (1), `recurseIntoFamTyConApp` sets `tef_fam_app := TEFA_Recurse`,+      before looking at the argument `(G alpha)`.  So we will not cycle-break+      the latter+    - The occurs check will fire when we hit `alpha`+    - `checkFamApp` on `(F (G alpha))` will see the failure and invoke+       the `FamAppBreaker`.++  * Step (1) may fail because of a level-check problem, which activates step (2).+    This is what implements (CFA2).+-}++-------------------+checkTyConApp :: Monad m+              => TyEqFlags m a+              -> TcType -> TyCon -> [TcType]+              -> m (PuResult a Reduction)+checkTyConApp flags tc_app tc tys+  | isTypeFamilyTyCon tc+  , let arity = tyConArity tc+  = if tys `lengthIs` arity+    then checkFamApp flags tc_app tc tys  -- Common case+    else do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys+                  fun_app                = mkTyConApp tc fun_args+            ; fun_res   <- checkFamApp flags fun_app tc fun_args+            ; extra_res <- mapCheck (check_ty_eq_rhs flags) extra_args+            ; return (mkAppRedns <$> fun_res <*> extra_res) }++  | Just ty' <- rewriterView tc_app+       -- e.g. S a  where  type S a = F [a]+       --             or   type S a = Int+       -- See Note [Forgetful synonyms in checkTyConApp]+  = check_ty_eq_rhs flags ty'++  | not (isTauTyCon tc)+  = return $ PuFail impredicativeProblem++  | tefConcrete flags+  , not (isConcreteTyCon tc)+  = return $ PuFail (cteProblem cteConcrete)++  | otherwise  -- Recurse on arguments+  = recurseIntoTyConApp flags tc tys++-------------------+recurseIntoTyConApp :: Monad m+                    => TyEqFlags m a+                    -> TyCon -> [TcType]+                    -> m (PuResult a Reduction)+recurseIntoTyConApp flags tc tys+  = do { tys_res <- mapCheck (check_ty_eq_rhs flags) tys+       ; return (mkTyConAppRedn Nominal tc <$> tys_res) }++recurseIntoFamTyConApp :: Monad m+                       => TyEqFlags m a+                       -> TyCon -> [TcType]+                       -> m (PuResult a Reduction)+recurseIntoFamTyConApp flags tc tys+  = recurseIntoTyConApp (famAppArgFlags flags) tc tys+    -- famAppArgFlags: adjust flags when going under fam app++-------------------++-- | See Note [Family applications in canonical constraints]+checkFamApp :: forall m a.+               Monad m+            => TyEqFlags m a+            -> TcType -> TyCon -> [TcType]  -- Saturated family application+            -> m (PuResult a Reduction)+checkFamApp flags fam_app tc tys =+  case flags of+    TEFTyFam { tefTyFam_tyCon = lhs_tc, tefTyFam_args = lhs_tys+             , tefTyFam_occursCheck = occ_prob }+      | tcEqTyConApps lhs_tc lhs_tys tc tys+      -- There is an occurs check F ty ~ ...(F ty)...+      -- Do not recurse; see (CFA1) in Note [Family applications in canonical constraints]+      -> do_not_recurse occ_prob+    TEFTyVar { tefTyVar_concreteCheck = conc }+      | wantConcreteCheck conc+      -- We are checking for concreteness, e.g. kappa[conc] ~ ...(F ty)...+      -- Do not recurse: type family applications are not concrete.+      -- See (CFA3) in Note [Family applications in canonical constraints]+      -> do_not_recurse cteConcrete+    _ ->+        -- We can recurse into the arguments of the type family application.+        case fam_flags of+          TEFA_Recurse   ->+            -- Simply recurse into the arguments.+            -- See (CFA4) in Note [Family applications in canonical constraints]+            recurseIntoFamTyConApp flags tc tys+          TEFA_Break brk ->+            -- Recurse into the arguments, and cycle-break if that fails+            --+            -- e.g.  alpha[2] ~ Maybe (F beta[2])    No problem: just unify+            --       alpha[2] ~ Maybe (F beta[4])    Level-check problem: break+            --+            -- NB: in the latter case, don't promote beta[4]; use 'recurseIntoFamTyConApp'+            -- which modifies the flags with 'famAppArgFlags'.+            do { rec_res <- recurseIntoFamTyConApp flags tc tys+               ; case rec_res of+                   PuOK {}   -> return rec_res+                   PuFail {} -> famAppBreaker brk fam_app+               }+  where+    fam_flags = tef_fam_app flags+    do_not_recurse prob =+      case fam_flags of+        TEFA_Recurse   -> return $ PuFail (cteProblem prob)+        TEFA_Break brk -> famAppBreaker brk fam_app++-------------------++-- | The result of a single check in 'checkTyVar', such as a concreteness check+-- or a level check.+data TyVarCheckResult m where+  -- | Check succeded; nothing else to do.+  TyVarCheck_Success :: TyVarCheckResult m+  -- | Check succeeded, but requires an additional promotion.+  --+  -- Invariant: at least one of the fields is not 'Nothing'.+  TyVarCheck_Promote+    :: Maybe TcLevel+         -- ^ @Just lvl@ <=> 'TyVar' needs to be promoted to @lvl@+    -> Maybe ConcreteTvOrigin+         -- ^ @Just conc_orig@ <=> 'TyVar' needs to be make concrete+    -> TyVarCheckResult TcM++  -- | Check failed with some 'CheckTyEqProblem's.+  --+  -- Invariant: the 'CheckTyEqResult' is not 'cteOK'.+  TyVarCheck_Error+    :: CheckTyEqResult -> TyVarCheckResult m++instance Semigroup (TyVarCheckResult m) where+  TyVarCheck_Success <> r = r+  r <> TyVarCheck_Success = r+  TyVarCheck_Error e1 <> TyVarCheck_Error e2 =+    TyVarCheck_Error (e1 S.<> e2)+  e@(TyVarCheck_Error {}) <> _ = e+  _ <> e@(TyVarCheck_Error {}) = e+  TyVarCheck_Promote l1 c1 <> TyVarCheck_Promote l2 c2 =+    TyVarCheck_Promote+      (combineMaybe minTcLevel l1 l2)+      (combineMaybe const c1 c2) -- pick one 'ConcreteTvOrigin' arbitrarily++combineMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a+combineMaybe _ Nothing r = r+combineMaybe _ r Nothing = r+combineMaybe f (Just a) (Just b) = Just (f a b)+instance Monoid (TyVarCheckResult m) where+  mempty = TyVarCheck_Success++checkTyVar :: forall m a. Monad m => TyEqFlags m a -> TcTyVar -> m (PuResult a Reduction)+checkTyVar flags occ_tv+  = case flags of+      TEFTyFam {}+        -> success   -- Nothing to do if the LHS is a type-family+      TEFTyVar { tefTyVar_occursCheck = occ, tefTyVar_levelCheck = lc+               , tefTyVar_concreteCheck = conc }+        -> do { already_promoted <- promotionDone occ_tv lc conc++              ; if already_promoted+                then success+                  -- Already promoted; job done+                  -- Example alpha[2] ~ Maybe (beta[4], beta[4])+                  -- We promote the first occurrence, and then encounter it+                  -- a second time; we don't want to re-promote it!+                  -- Remember, the entire process started with a fully zonked type+                  -- so the only reason for a filled meta-tyvar is promotion++                else do_rhs_checks+                     [ simpleOccursCheck      occ  occ_tv+                     , tyVarLevelCheck        lc   occ_tv+                     , tyVarConcretenessCheck conc occ_tv ]+              }+  where+    success = return $ okCheckRefl (mkTyVarTy occ_tv)++    -- Combine the results of individual checks. See 'TyVarCheckResult'.+    do_rhs_checks :: [TyVarCheckResult m] -> m (PuResult a Reduction)+    do_rhs_checks checks =+      case mconcat checks of+        TyVarCheck_Success                -> success+        TyVarCheck_Promote mb_lvl mb_conc -> promote flags mb_lvl mb_conc+        TyVarCheck_Error cte_prob         -> return $ PuFail cte_prob++    ---------------------+    -- occ_tv is definitely a MetaTyVar; we need to promote it/make it concrete+    promote :: TyEqFlags TcM a -> Maybe TcLevel -> Maybe ConcreteTvOrigin+            -> TcM (PuResult a Reduction)+    promote flags mb_lhs_tv_lvl mb_conc+      | MetaTv { mtv_info = info_occ, mtv_tclvl = lvl_occ } <- tcTyVarDetails occ_tv+      = do { let new_info | Just conc <- mb_conc = ConcreteTv conc+                          | otherwise            = info_occ+                 new_lvl =+                    case mb_lhs_tv_lvl of+                      Nothing         -> lvl_occ+                      Just lhs_tv_lvl -> lhs_tv_lvl `minTcLevel` lvl_occ+                        -- c[conc,3] ~ p[tau,2]: want to clone p:=p'[conc,2]+                        -- c[tau,2]  ~ p[tau,3]: want to clone p:=p'[tau,2]++           -- Check the kind of occ_tv+           --+           -- This is important for several reasons:+           --+           --  1. To ensure there is no occurs check or skolem-escape+           --     in the kind of occ_tv.+           --  2. If the LHS is a concrete type variable and the RHS is an+           --     unfilled meta-tyvar, we need to ensure that the kind of+           --     'occ_tv' is concrete.   Test cases: T23051, T23176.+           ; let occ_kind = tyVarKind occ_tv+           ; kind_result <- check_ty_eq_rhs flags occ_kind+           ; for kind_result $ \ kind_redn ->+        do { let kind_co  = reductionCoercion kind_redn+                 new_kind = reductionReducedType kind_redn+                 occ_tv'  = setTyVarKind occ_tv new_kind+           ; new_tv_ty <- promote_meta_tyvar new_info new_lvl occ_tv'+           ; return $ mkGReflLeftRedn Nominal new_tv_ty (mkSymCo kind_co)+           } }++      | otherwise = pprPanic "promote" (ppr occ_tv)++---------------------+promotionDone :: Monad m => TcTyVar -> LevelCheck m -> ConcreteCheck m -> m Bool+promotionDone occ_tv (LC_Promote {}) _ = isFilledMetaTyVar occ_tv+promotionDone occ_tv _ (CC_Promote {}) = isFilledMetaTyVar occ_tv+promotionDone _      _               _ = return False++---------------------+simpleOccursCheck :: OccursCheck -> TcTyVar -> TyVarCheckResult m+-- ^ The "interpreter" for 'OccursCheck'+simpleOccursCheck OC_None _+  = TyVarCheck_Success+simpleOccursCheck (OC_Check lhs_tv occ_prob) occ_tv+  | lhs_tv == tyVarName occ_tv || check_kind (tyVarKind occ_tv)+  = TyVarCheck_Error (cteProblem occ_prob)+  | otherwise+  = TyVarCheck_Success+  where+    (check_kind, _) = mkOccFolders lhs_tv++-------------------------+tyVarLevelCheck :: LevelCheck m -> TcTyVar -> TyVarCheckResult m+-- ^ The "interpreter" for 'LevelCheck'+tyVarLevelCheck LC_None _ = TyVarCheck_Success+tyVarLevelCheck lc occ_tv+  | not occ_is_deeper+  = TyVarCheck_Success+  | isSkolemTyVar occ_tv+  = TyVarCheck_Error (cteProblem cteSkolemEscape)+  | otherwise+  = case lc of+      LC_Check { lc_lenient = lenient } ->+        if lenient+        then TyVarCheck_Success+        else TyVarCheck_Error (cteProblem cteSkolemEscape)+      LC_Promote { lc_lvlp = lhs_tv_lvl } ->+        TyVarCheck_Promote (Just lhs_tv_lvl) Nothing+  where+    occ_is_deeper =+      case lc of+        LC_Check { lc_lvlc = lhs_tv_lvl } ->+          tcTyVarLevel occ_tv `strictlyDeeperThan` lhs_tv_lvl+        LC_Promote { lc_lvlp = lhs_tv_lvl } ->+          tcTyVarLevel occ_tv `strictlyDeeperThan` lhs_tv_lvl++-------------------------+tyVarConcretenessCheck :: ConcreteCheck m -> TcTyVar -> TyVarCheckResult m+-- ^ The "interpreter" for 'ConcreteCheck'+tyVarConcretenessCheck cc occ_tv+  | CC_None <- cc             -- No concreteness checks => ok+  = TyVarCheck_Success+  | isConcreteTyVar occ_tv    -- It's concrete already  => ok+  = TyVarCheck_Success+  | not (isMetaTyVar occ_tv)  -- Not a meta-tyvar => error+  = TyVarCheck_Error (cteProblem cteConcrete)++  | otherwise  -- It's a non-concrete meta-tyvar+  = case cc of+       CC_Check -> TyVarCheck_Success+       CC_Promote conc_orig -> TyVarCheck_Promote Nothing (Just conc_orig)+       -- CC_None is dealt with at the top++-------------------------+checkPromoteFreeVars :: CheckTyEqProblem    -- What occurs check problem to report+                     -> Name -> TcLevel+                     -> TyCoVarSet -> TcM CheckTyEqResult+-- Check this set of TyCoVars for+--   (a) occurs check+--   (b) promote if necessary, or report skolem escape+checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl vs+  = do { oks <- mapM do_one (nonDetEltsUniqSet vs)+       ; return (mconcat oks) }+  where+    do_one :: TyCoVar -> TcM CheckTyEqResult+    do_one v | isCoVar v             = return cteOK+             | tyVarName v == lhs_tv = return (cteProblem occ_prob)+             | no_promotion          = return cteOK+             | not (isMetaTyVar v)   = return (cteProblem cteSkolemEscape)+             | otherwise             = promote_one v+      where+        no_promotion = not (tcTyVarLevel v `strictlyDeeperThan` lhs_tv_lvl)++    -- isCoVar case: coercion variables are not an escape risk+    -- If an implication binds a coercion variable, it'll have equalities,+    -- so the "intervening given equalities" test above will catch it+    -- Coercion holes get filled with coercions, so again no problem.++    promote_one :: TyVar -> TcM CheckTyEqResult+    promote_one tv =+      do { _ <- promote_meta_tyvar TauTv lhs_tv_lvl tv+         ; return cteOK }++promote_meta_tyvar :: MetaInfo -> TcLevel -> TcTyVar -> TcM TcType+promote_meta_tyvar info dest_lvl occ_tv+  = do { -- Check whether occ_tv is already unified. The rhs-type+         -- started zonked, but we may have promoted one of its type+         -- variables, and we then encounter it for the second time.+         -- But if so, it'll definitely be another already-checked TyVar+         mb_filled <- isFilledMetaTyVar_maybe occ_tv+       ; case mb_filled of {+           Just ty -> return ty ;+           Nothing ->++    -- OK, not done already, so clone/promote it+    do { new_tv <- cloneMetaTyVarWithInfo info dest_lvl occ_tv+       ; liftZonkM $ writeMetaTyVar occ_tv (mkTyVarTy new_tv)+       ; traceTc "promoteTyVar" (ppr occ_tv <+> text "-->" <+> ppr new_tv)+       ; return (mkTyVarTy new_tv) } } }++++-------------------------+touchabilityTest :: TcLevel -> TcTyVar -> Bool+-- ^ This is the key test for untouchability:+-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify+-- and Note [Solve by unification] in GHC.Tc.Solver.Equality+--+-- @True@ <=> the variable is touchable+touchabilityTest given_eq_lvl tv+  | MetaTv { mtv_tclvl = tv_lvl } <- tcTyVarDetails tv+  = tv_lvl `deeperThanOrSame` given_eq_lvl+  | otherwise+  = False++-------------------------+-- | checkTopShape checks (TYVAR-TV)+-- Note [Unification preconditions]; returns True if these conditions+-- are satisfied. But see the Note for other preconditions, too.+checkTopShape :: MetaInfo -> TcType -> Bool+checkTopShape info xi+  = case info of+      TyVarTv ->+        case getTyVar_maybe xi of   -- Looks through type synonyms+           Nothing -> False+           Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle+                        SkolemTv {} -> True+                        RuntimeUnk  -> True+                        MetaTv { mtv_info = TyVarTv } -> True+                        _                             -> False+      CycleBreakerTv -> False  -- We never unify these+      _ -> True++--------------------------------------------------------------------------------+-- Making a type concrete.++-- | Try to turn the provided type into a concrete type, by ensuring+-- unfilled metavariables are appropriately marked as concrete.+--+-- Returns a coercion whose RHS is a zonked type which is "as concrete as possible",+-- and a collection of Wanted equality constraints that are necessary to make+-- the type concrete.+--+-- For example, for an input @TYPE a[sk]@ we will return a coercion with RHS+-- @TYPE gamma[conc]@ together with the Wanted equality constraint @a ~# gamma@.+--+-- INVARIANT: the RHS type of the returned coercion is equal to the input type,+-- up to zonking and the returned Wanted equality constraints.+--+-- INVARIANT: if this function returns an empty list of constraints+-- then the RHS type of the returned coercion is concrete,+-- in the sense of Note [Concrete types].+makeTypeConcrete :: FastString -> ConcreteTvOrigin+                 -> TcType -> TcM (TcCoercion, Cts)+makeTypeConcrete occ_fs conc_orig ty =+  do { traceTc "makeTypeConcrete {" $+        vcat [ text "ty:" <+> ppr ty ]++     -- To make a type 'ty' concrete, we query what would happen were we+     -- to try unifying+     --+     --   alpha[conc] ~# ty+     --+     -- for a fresh concrete metavariable 'alpha'.+     --+     -- We do this by calling 'checkTyEqRhs' with suitable 'TyEqFlags'.+     -- NB: we don't actually need to create a fresh concrete metavariable+     -- in order to call 'checkTyEqRhs'.+     ; let ty_eq_flags =+            TEFTyVar+              { tefTyVar_occursCheck   = OC_None+                  -- LHS is a fresh meta-tyvar: no occurs check needed+              , tefTyVar_levelCheck    = LC_None+              , tefTyVar_concreteCheck = CC_Promote conc_orig+              , tef_fam_app            = TEFA_Recurse+              }++     -- NB: 'checkTyEqRhs' expects a fully zonked type as input.+     ; ty' <- liftZonkM $ zonkTcType ty+     ; pu_res <- checkTyEqRhs @TcM @() ty_eq_flags ty'+     -- NB: 'checkTyEqRhs' will also check the kind, thus upholding the+     -- invariant that the kind of a concrete type must also be a concrete type.++     ; (cts, final_co) <-+         case pu_res of+           PuOK _ redn ->+            do { traceTc "makeTypeConcrete: unifier success" $+                   vcat [ text "ty:" <+> ppr ty <+> dcolon <+> ppr (typeKind ty)+                        , text "redn:" <+> ppr redn+                        ]+               ; return (emptyBag, mkSymCo $ reductionCoercion redn)+                  -- NB: the unifier returns a 'Reduction' with the concrete+                  -- type on the left, but we want a coercion with it on the+                  -- right; so we use 'mkSymCo'.+               }+           PuFail _prob ->+             do { traceTc "makeTypeConcrete: unifier failure" $+                   vcat [ text "ty:" <+> ppr ty <+> dcolon <+> ppr (typeKind ty)+                        , text "problem:" <+> ppr _prob+                        ]+                  -- We failed to make 'ty' concrete. In order to continue+                  -- typechecking, we proceed as follows:+                  --+                  --   - create a new concrete metavariable alpha[conc]+                  --   - emit the equality @ty ~# alpha[conc]@.+                  --+                  -- This equality will eventually get reported as insoluble+                  -- to the user.++                -- The kind of a concrete metavariable must itself be concrete,+                -- so we need to do a concreteness check on the kind first.+                ; let ki = typeKind ty+                ; (kind_co, kind_cts) <-+                    if isConcreteType ki+                    then return (mkNomReflCo ki, emptyBag)+                    else makeTypeConcrete occ_fs conc_orig ki++                -- Now create the new concrete metavariable.+                ; conc_tv <- newConcreteTyVar conc_orig occ_fs (coercionRKind kind_co)+                ; let conc_ty = mkTyVarTy conc_tv+                      pty = mkEqPredRole Nominal ty' conc_ty+                ; hole <- newCoercionHole pty+                ; loc <- getCtLocM orig (Just KindLevel)+                ; let ct = mkNonCanonical $ CtWanted+                         $ WantedCt { ctev_pred      = pty+                                    , ctev_dest      = HoleDest hole+                                    , ctev_loc       = loc+                                    , ctev_rewriters = emptyRewriterSet }+                ; return (kind_cts S.<> unitBag ct, HoleCo hole)+                }++     ; traceTc "makeTypeConcrete }" $+        vcat [ text "ty :" <+> _ppr_ty ty+             , text "ty':" <+> _ppr_ty ty'+             , text "final_co:" <+> _ppr_co final_co ]++     ; return (final_co, cts)+     }+  where++    _ppr_ty ty = ppr ty <+> dcolon <+> ppr (typeKind ty)+    _ppr_co co = ppr co <+> dcolon <+> parens (_ppr_ty (coercionLKind co)) <+> text "~#" <+> parens (_ppr_ty (coercionRKind co))++    orig :: CtOrigin+    orig = case conc_orig of+      ConcreteFRR frr_orig -> FRROrigin frr_orig+++{- *********************************************************************+*                                                                      *+                 mightEqualLater+*                                                                      *+********************************************************************* -}++{- Note [What might equal later?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must determine whether a Given might later equal a Wanted:+  see Note [Instance and Given overlap] in GHC.Tc.Solver.Dict++We definitely need to account for the possibility that any metavariable might be+arbitrarily instantiated. Yet we do *not* want to allow skolems 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[tau]  ~?  C Int++   That Given certainly might match later.++2. C a[sk]  ~?  C Int++   No. No new givens are going to arise that will get the `a` to rewrite+   to Int.  Example:+      f :: forall a. C a => blah+      f = rhs  -- Gives rise to [W] C Int+   It would be silly to fail to solve ([W] C Int), just because we have+   ([G] C a) in the Givens!++3. C alpha[tv]   ~?  C Int++   In this variant of (1) that alpha[tv] is a TyVarTv, unifiable only with+   other type /variables/.  It cannot equal Int later.++4. C (F alpha[tau])   ~?   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[sk])  ~?  C Int.  For example+      f :: forall a. C (F a) => blah+      f = rhs  -- Gives rise to [W] C Int++   No, this won't match later. If we could rewrite (F a), we would+   have by now. But see also Red Herring below.++   This arises in instance decls too.  For example in GHC.Core.Ppr we see+     instance Outputable (XTickishId pass)+           => Outputable (GenTickish pass) where+   If we have [W] Outputable Int in the body, we don't want to fail to solve+   it because (XTickishId pass) might simplify to Int.++7. C (Maybe alpha[tau])  ~?  C alpha[tau]++   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 led to #19107, tested in+   typecheck/should_compile/T19107.++8. C alpha[cbv]   ~?  C Int+   where alpha[cbv] = F a++   The alpha[cbv] is a cycle-breaker var which stands for F a. See+   Note [Type equality cycles] in GHC.Tc.Solver.Equality+   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 alpha[cbv]   ~?   C Int+   where alpha[cbv] = F beta[tau]++   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[tau], Int)  ~?  C (Bool, F alpha[tau])++   This cannot equal later, because F alpha would have to equal both Bool and+   Int.++To deal with type family applications, we use the "fine-grained" Core unifier.+See Note [Apartness and type families] in GHC.Core.Unify, controlled+by the `bind_fam :: BindFamFun` function defined in `mightEqualLater`.++One tricky point: 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. However: 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. See the+use of `mentions_meta_ty_var` in `mightEqualLater`.++This treatment fixes #18910 and is tested in+typecheck/should_compile/InstanceGivenOverlap{,2}++Red Herring+~~~~~~~~~~~+In #21208, we have this scenario:++  instance forall b. C b+  [G] C a[sk]+  [W] C (F a[sk])++What should we do with that wanted? According to the logic above, the Given+cannot match later (this is example 6), and so we use the global instance.+But wait, you say: What if we learn later (say by a future type instance F a = a)+that F a unifies with a? That looks like the Given might really match later!++This mechanism described in this Note is *not* about this kind of situation, however.+It is all asking whether a Given might match the Wanted *in this run of the solver*.+It is *not* about whether a variable might be instantiated so that the Given matches,+or whether a type instance introduced in a downstream module might make the Given match.+The reason we care about what might match later is only about avoiding order-dependence.+That is, we don't want to commit to a course of action that depends on seeing constraints+in a certain order. But an instantiation of a variable and a later type instance+don't introduce order dependency in this way, and so mightMatchLater is right to ignore+these possibilities.++Here is an example, with no type families, that is perhaps clearer:++  instance forall b. C (Maybe b)+  [G] C (Maybe Int)+  [W] C (Maybe a)++What to do? We *might* say that the Given could match later and should thus block+us from using the global instance. But we don't do this. Instead, we rely on class+coherence to say that choosing the global instance is just fine, even if later we+call a function with (a := Int). After all, in this run of the solver, [G] C (Maybe Int)+will definitely never match [W] C (Maybe a). (Recall that we process Givens before+Wanteds, so there is no [G] a ~ Int hanging about unseen.)++Interestingly, in the first case (from #21208), the behavior changed between+GHC 8.10.7 and GHC 9.2, with the latter behaving correctly and the former+reporting overlapping instances.++Test case: typecheck/should_compile/T21208.++-}++--------------------------------------------------------------------------------+-- mightEqualLater++mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Maybe Subst+-- See Note [What might equal later?]+-- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Dict+mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc+  | prohibitedSuperClassSolve given_loc wanted_loc+  = Nothing++  | otherwise+  = case tcUnifyTysFG bind_fam bind_tv [given_pred] [wanted_pred] of+      Unifiable subst+        -> Just subst+      MaybeApart reason subst+        | MARInfinite <- reason -- see Example 7 in the Note.+        -> Nothing+        | otherwise+        -> Just subst+      SurelyApart -> Nothing++  where+    bind_tv :: BindTvFun+    bind_tv tv rhs_ty+      | MetaTv { mtv_info = info } <- tcTyVarDetails tv+      , ok_shape tv info rhs_ty+      , can_unify tv rhs_ty+      = BindMe++      | otherwise+      = DontBindMe++    bind_fam :: BindFamFun+    -- See Examples (4), (5), and (6) from the Note, especially (6)+    bind_fam _fam_tc fam_args _rhs+      | anyFreeVarsOfTypes mentions_meta_ty_var fam_args = BindMe+      | otherwise                                        = DontBindMe++    can_unify :: TcTyVar -> TcType -> Bool+    can_unify tv rhs_ty+      -- See Note [Use checkTyEqRhs in mightEqualLater]+      | PuOK {} <- runIdentity $ checkTyEqRhs (pureTyEqFlags_LHSMetaTyVar tv) rhs_ty+      = True+      | otherwise+      = False++    -- 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 -> anyFreeVarsOfType mentions_meta_ty_var+                              (lookupCycleBreakerVar tv inert_set)+          _ -> True+      | otherwise+      = False++    -- Like checkTopShape, but allows cbv variables to unify+    ok_shape :: TcTyVar -> MetaInfo -> Type -> Bool+    ok_shape _lhs_tv TyVarTv rhs_ty  -- see Example 3 from the Note+      | Just rhs_tv <- getTyVar_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+    ok_shape lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv++{- Note [Use checkTyEqRhs in mightEqualLater]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In 'mightEqualLater', we are checking whether two types ty1 and ty2 might become+equal after further unifications. To do this, we call the pure unifier, via+the function 'tcUnifyTysFG'. However, it is important that we don't return+false positives:++  1. Level check:  ty1 = alpha[tau:1] /~ ty2 = k[sk:3]+  2. Occurs check: ty1 = beta[tau]    /~ ty2 = Maybe beta[tau]+  3. Concreteness: ty1 = kappa[conc]  /~ ty2 = k[sk].++In these examples, ty1 and ty2 cannot unify; to inform the pure unifier of this+fact, we use 'checkTyEqRhs' to provide the 'BindTvFun'.++Failing to account for this caused #25744:++  work item = [W] w1: Eq (g[sk:1] x[sk:3])+  inerts = { [G] g1: Eq x[sk:3]+           , [G] g2: forall y. Eq y => Eq (g[sk:1] y)+           , [G] g3: Eq (f[tau:1] v[tau:1]) }++We want to solve w1 using g1 and g2. The presence of g3 is irrelevant, because+we cannot unify 'f[tau:1] v[tau:1]' and 'g[sk:1] x[sk:3]' due to skolem escape.+-}++-- | Return the type family application a CycleBreakerTv maps to.+lookupCycleBreakerVar :: TcTyVar    -- ^ cbv, must be a CycleBreakerTv+                      -> InertSet+                      -> TcType     -- ^ type family application the cbv maps to+lookupCycleBreakerVar cbv (IS { inert_cycle_breakers = cbvs_stack })+-- This function looks at every environment in the stack. This is necessary+-- to avoid #20231. This function (and its one usage site) is the only reason+-- that we store a stack instead of just the top environment.+  | Just tyfam_app <- assert (isCycleBreakerTyVar cbv) $+                      firstJusts (NE.map (lookupBag cbv) cbvs_stack)+  = tyfam_app+  | otherwise+  = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack)++--------------------------------------------------------------------------------
compiler/GHC/Tc/Utils/Unify.hs-boot view
@@ -1,17 +1,24 @@ module GHC.Tc.Utils.Unify where  import GHC.Prelude-import GHC.Core.Type         ( Mult )-import GHC.Tc.Utils.TcType   ( TcTauType )-import GHC.Tc.Types          ( TcM )-import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper )-import GHC.Tc.Types.Origin   ( CtOrigin, TypedThing )+import GHC.Core.Type           ( Mult )+import GHC.Tc.Utils.TcType     ( TcTauType )+import GHC.Tc.Types            ( TcM )+import GHC.Tc.Types.Constraint ( Cts )+import GHC.Tc.Types.Evidence   ( TcCoercion )+import GHC.Tc.Types.Origin     ( CtOrigin, TypedThing )+import GHC.Tc.Utils.TcType     ( TcType, ConcreteTvOrigin ) +import GHC.Data.FastString ( FastString ) + -- This boot file exists only to tie the knot between --   GHC.Tc.Utils.Unify and GHC.Tc.Utils.Instantiate/GHC.Tc.Utils.TcMType  unifyType          :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion unifyInvisibleType :: TcTauType -> TcTauType -> TcM TcCoercion -tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper+tcSubMult :: CtOrigin -> Mult -> Mult -> TcM ()++makeTypeConcrete :: FastString -> ConcreteTvOrigin+                 -> TcType -> TcM (TcCoercion, Cts)
compiler/GHC/Tc/Validity.hs view
@@ -1,9 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -29,13 +26,13 @@ import GHC.Tc.Utils.Unify    ( tcSubTypeAmbiguity ) import GHC.Tc.Solver         ( simplifyAmbiguityCheck ) import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo(..) )-import GHC.Tc.Utils.TcType+import GHC.Tc.Instance.FunDeps+import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types+import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad-import GHC.Tc.Instance.FunDeps-import GHC.Tc.Instance.Family import GHC.Tc.Zonk.TcType  import GHC.Builtin.Types@@ -52,6 +49,7 @@ import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Tidy import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches                            , InjectivityCheckResult(..) ) @@ -241,7 +239,7 @@          -- tyvars are skolemised, we can safely use tcSimplifyTop        ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes        ; unless allow_ambiguous $-         do { (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $+         do { (_wrap, wanted) <- addErrCtxt (AmbiguityCheckCtxt ctxt allow_ambiguous) $                                  captureConstraints $                                  tcSubTypeAmbiguity ctxt ty ty                                  -- See Note [Ambiguity check and deep subsumption]@@ -252,13 +250,6 @@    | otherwise   = return ()- where-   mk_msg allow_ambiguous-     = vcat [ text "In the ambiguity check for" <+> what-            , ppUnless allow_ambiguous ambig_msg ]-   ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"-   what | Just n <- isSigMaybe ctxt = quotes (ppr n)-        | otherwise                 = pprUserTypeCtxt ctxt  wantAmbiguityCheck :: UserTypeCtxt -> Bool wantAmbiguityCheck ctxt@@ -381,7 +372,6 @@                = case ctxt of                  DefaultDeclCtxt-> MustBeMonoType                  PatSigCtxt     -> rank0-                 RuleSigCtxt {} -> rank1                  TySynCtxt _    -> rank0                   ExprSigCtxt {} -> rank1@@ -405,10 +395,11 @@                  SpecInstCtxt   -> rank1                  GhciCtxt {}    -> ArbitraryRank -                 TyVarBndrKindCtxt _ -> rank0-                 DataKindCtxt _      -> rank1-                 TySynKindCtxt _     -> rank1-                 TyFamResKindCtxt _  -> rank1+                 TyVarBndrKindCtxt {} -> rank0+                 RuleBndrTypeCtxt{}   -> rank1+                 DataKindCtxt _       -> rank1+                 TySynKindCtxt _      -> rank1+                 TyFamResKindCtxt _   -> rank1                   _              -> panic "checkValidType"                                           -- Can't happen; not used for *user* sigs@@ -542,7 +533,7 @@ typeOrKindCtxt (TypeAppCtxt {})     = OnlyTypeCtxt typeOrKindCtxt (PatSynCtxt {})      = OnlyTypeCtxt typeOrKindCtxt (PatSigCtxt {})      = OnlyTypeCtxt-typeOrKindCtxt (RuleSigCtxt {})     = OnlyTypeCtxt+typeOrKindCtxt (RuleBndrTypeCtxt {})= OnlyTypeCtxt typeOrKindCtxt (ForSigCtxt {})      = OnlyTypeCtxt typeOrKindCtxt (DefaultDeclCtxt {}) = OnlyTypeCtxt typeOrKindCtxt (InstDeclCtxt {})    = OnlyTypeCtxt@@ -880,10 +871,8 @@     check_expansion_only expand       = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $         case coreView ty of-         Just ty' -> let err_ctxt = text "In the expansion of type synonym"-                                    <+> quotes (ppr tc)-                     in addErrCtxt err_ctxt $-                        check_type (ve{ve_expand = expand}) ty'+         Just ty' -> addErrCtxt (TySynErrCtxt tc) $+                     check_type (ve{ve_expand = expand}) ty'          Nothing  -> pprPanic "check_syn_tc_app" (ppr ty)  {-@@ -1012,18 +1001,11 @@  -- | Check for a DataKinds violation in a kind context. -- See @Note [Checking for DataKinds]@.------ Note that emitting DataKinds errors from the typechecker is a fairly recent--- addition to GHC (introduced in GHC 9.10), and in order to prevent these new--- errors from breaking users' code, we temporarily downgrade these errors to--- warnings. (This is why we use 'diagnosticTcM' below.) See--- @Note [Checking for DataKinds] (Wrinkle: Migration story for DataKinds--- typechecker errors)@. checkDataKinds :: ValidityEnv -> Type -> TcM () checkDataKinds (ValidityEnv{ ve_ctxt = ctxt, ve_tidy_env = env }) ty = do   data_kinds <- xoptM LangExt.DataKinds-  diagnosticTcM-    (not (data_kinds || typeLevelUserTypeCtxt ctxt)) $+  checkTcM+    (data_kinds || typeLevelUserTypeCtxt ctxt) $     (env, TcRnDataKindsError KindLevel (Right (tidyType env ty)))  {- Note [No constraints in kinds]@@ -1175,28 +1157,6 @@   synonym), so we also catch a subset of kind-level violations in the renamer   to allow for earlier reporting of these errors. --------- Wrinkle: Migration story for DataKinds typechecker errors--------As mentioned above, DataKinds is checked in two different places: the renamer-and the typechecker. The checks in the renamer have been around since DataKinds-was introduced. The checks in the typechecker, on the other hand, are a fairly-recent addition, having been introduced in GHC 9.10. As such, it is possible-that there are some programs in the wild that (1) do not enable DataKinds, and-(2) were accepted by a previous GHC version, but would now be rejected by the-new DataKinds checks in the typechecker.--To prevent the new DataKinds checks in the typechecker from breaking users'-code, we temporarily allow programs to compile if they violate a DataKinds-check in the typechecker, but GHC will emit a warning if such a violation-occurs. Users can then silence the warning by enabling DataKinds in the module-where the affected code lives. It is fairly straightforward to distinguish-between DataKinds violations arising from the renamer versus the typechecker,-as TcRnDataKindsError (the error message type classifying all DataKinds errors)-stores an Either field that is Left when the error comes from the renamer and-Right when the error comes from the typechecker.- ************************************************************************ *                                                                      * \subsection{Checking a theta or source type}@@ -1309,7 +1269,7 @@ check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt                  -> PredType -> ThetaType -> PredType -> TcM () check_quant_pred env dflags ctxt pred theta head_pred-  = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $+  = addErrCtxt (QuantifiedCtCtxt pred) $     do { -- Check the instance head          case classifyPredType head_pred of                                  -- SigmaCtxt tells checkValidInstHead that@@ -1400,7 +1360,7 @@                 -- (Coercible a b) to (a ~R# b)    | otherwise-  = do { result <- matchGlobalInst dflags False cls tys+  = do { result <- matchGlobalInst dflags False cls tys Nothing        ; case result of            OneInst { cir_what = what }               -> addDiagnosticTc (TcRnSimplifiableConstraint pred what)@@ -1466,7 +1426,7 @@ okIPCtxt (ClassSCCtxt {})       = False okIPCtxt (InstDeclCtxt {})      = False okIPCtxt (SpecInstCtxt {})      = False-okIPCtxt (RuleSigCtxt {})       = False+okIPCtxt (RuleBndrTypeCtxt {})  = False okIPCtxt DefaultDeclCtxt        = False okIPCtxt DerivClauseCtxt        = False okIPCtxt (TyVarBndrKindCtxt {}) = False@@ -1495,11 +1455,9 @@   generalized actually. -} -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> ZonkM (TidyEnv, SDoc)+checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) checkThetaCtxt ctxt theta env-  = return ( env-           , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)-                  , text "While checking" <+> pprUserTypeCtxt ctxt ] )+  = return (env, ThetaCtxt ctxt (tidyTypes env theta))  tyConArityErr :: TyCon -> [TcType] -> TcRnMessage -- For type-constructor arity errors, be careful to report@@ -1577,7 +1535,7 @@   | isAbstractClass clas   , hs_src == HsSrcFile   = fail_with_inst_err $ IllegalInstanceHead-                       $ InstHeadAbstractClass clas+                       $ InstHeadAbstractClass (noUserRdr $ className clas)    -- Complain about hand-written instances of built-in classes   -- Typeable, KnownNat, KnownSymbol, Coercible, HasField.@@ -2124,9 +2082,10 @@         ; traceTc "End checkValidInstance }" empty }     | otherwise     -> failWithTc $ mk_err $ IllegalInstanceHead-                           $ InstHeadNonClass (Just tc)+                           $ InstHeadNonClassHead+                           $ InstNonClassTyCon (noUserRdr $ tyConName tc) (fmap tyConName $ tyConFlavour tc)   _ -> failWithTc $ mk_err $ IllegalInstanceHead-                           $ InstHeadNonClass Nothing+                           $ InstHeadNonClassHead InstNonTyCon   where     (theta, tau) = splitInstTyForValidity ty @@ -2625,7 +2584,7 @@     -- The /scoped/ type variables from the class-instance header     -- should not be alpha-renamed.  Inferred ones can be.     no_bind_set = mkVarSet inst_tvs-    bind_me tv _ty | tv `elemVarSet` no_bind_set = Apart+    bind_me tv _ty | tv `elemVarSet` no_bind_set = DontBindMe                    | otherwise                   = BindMe  
compiler/GHC/Tc/Zonk/Env.hs view
@@ -61,10 +61,14 @@ -- -- See Note [Un-unified unification variables] data ZonkFlexi-  = DefaultFlexi    -- ^ Default unbound unification variables to Any-  | SkolemiseFlexi  -- ^ Skolemise unbound unification variables-                    --   See Note [Zonking the LHS of a RULE]+  = DefaultFlexi       -- ^ Default unbound unification variables to Any++  | SkolemiseFlexi     -- ^ Skolemise unbound unification variables+      (IORef [TyVar])  --   See Note [Zonking the LHS of a RULE]+                       --   Records the tyvars thus skolemised+   | RuntimeUnkFlexi -- ^ Used in the GHCi debugger+   | NoFlexi         -- ^ Panic on unfilled meta-variables                     -- See Note [Error on unconstrained meta-variables]                     -- in GHC.Tc.Utils.TcMType
compiler/GHC/Tc/Zonk/TcType.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DuplicateRecordFields #-}  {- (c) The University of Glasgow 2006@@ -37,6 +38,13 @@     -- ** Zonking constraints   , zonkCt, zonkWC, zonkSimples, zonkImplication +    -- * Rewriter sets+  , zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet++    -- * Coercion holes+  , isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe++     -- * Tidying   , tcInitTidyEnv, tcInitOpenTidyEnv   , tidyCt, tidyEvVar, tidyDelayedError@@ -75,13 +83,14 @@  import GHC.Core.InstEnv (ClsInst(is_tys)) import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Tidy import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Predicate  import GHC.Utils.Constants-import GHC.Utils.Outputable+import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Utils.Monad ( mapAccumLM ) import GHC.Utils.Panic@@ -89,6 +98,9 @@ import GHC.Data.Bag import GHC.Data.Pair +import Data.Semigroup+import Data.Maybe+ {- ********************************************************************* *                                                                      *                     Writing to metavariables@@ -354,8 +366,9 @@ ************************************************************************ -} --- | Check that a coercion is appropriate for filling a hole. (The hole--- itself is needed only for printing.)+-- | Debugging-only!  Check that a coercion is appropriate for filling a+--   hole. (The hole itself is needed only for printing.)+-- -- Always returns the checked coercion, but this return value is necessary -- so that the input coercion is forced only when the output is forced. checkCoercionHole :: CoVar -> Coercion -> ZonkM Coercion@@ -366,8 +379,8 @@        ; return $          assertPpr (ok cv_ty)                    (text "Bad coercion hole" <+>-                    ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role-                                             , ppr cv_ty ])+                    ppr cv Outputable.<> colon+                    <+> vcat [ ppr t1, ppr t2, ppr role, ppr cv_ty ])          co }   | otherwise   = return co@@ -429,6 +442,8 @@   = DE_Hole <$> zonkHole hole zonkDelayedError (DE_NotConcrete err)   = DE_NotConcrete <$> zonkNotConcreteError err+zonkDelayedError (DE_Multiplicity mult_co loc)+  = DE_Multiplicity <$> zonkCo mult_co <*> pure loc  zonkHole :: Hole -> ZonkM Hole zonkHole hole@(Hole { hole_ty = ty })@@ -492,10 +507,15 @@        ; return (mkNonCanonical fl') }  zonkCtEvidence :: CtEvidence -> ZonkM CtEvidence-zonkCtEvidence ctev-  = do { let pred = ctev_pred ctev-       ; pred' <- zonkTcType pred-       ; return (setCtEvPredType ctev pred') }+-- Zonks the ctev_pred and the ctev_rewriters; but not ctev_evar+-- For ctev_rewriters, see (WRW2) in Note [Wanteds rewrite Wanteds]+zonkCtEvidence (CtGiven (GivenCt { ctev_pred = pred, ctev_evar = var, ctev_loc = loc }))+  = do { pred' <- zonkTcType pred+       ; return (CtGiven (GivenCt { ctev_pred = pred', ctev_evar = var, ctev_loc = loc })) }+zonkCtEvidence (CtWanted wanted@(WantedCt { ctev_pred = pred, ctev_rewriters = rws }))+  = do { pred' <- zonkTcType pred+       ; rws'  <- zonkRewriterSet rws+       ; return (CtWanted (wanted { ctev_pred = pred', ctev_rewriters = rws' })) }  zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk@@ -531,6 +551,103 @@  %************************************************************************ %*                                                                      *+                 Zonking rewriter sets+*                                                                      *+************************************************************************+-}++zonkCtRewriterSet :: Ct -> ZonkM Ct+zonkCtRewriterSet ct+  | isGivenCt ct+  = return ct+  | otherwise+  = case ct of+      CEqCan eq@(EqCt { eq_ev = ev })       -> do { ev' <- zonkCtEvRewriterSet ev+                                                  ; return (CEqCan (eq { eq_ev = ev' })) }+      CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev+                                                  ; return (CIrredCan (ir { ir_ev = ev' })) }+      CDictCan di@(DictCt { di_ev = ev })   -> do { ev' <- zonkCtEvRewriterSet ev+                                                  ; return (CDictCan (di { di_ev = ev' })) }+      CQuantCan {}     -> return ct+      CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev+                             ; return (CNonCanonical ev') }++zonkCtEvRewriterSet :: CtEvidence -> ZonkM CtEvidence+zonkCtEvRewriterSet ev@(CtGiven {})+  = return ev+zonkCtEvRewriterSet ev@(CtWanted wtd)+  = do { rewriters' <- zonkRewriterSet (ctEvRewriters ev)+       ; return (CtWanted $ setWantedCtEvRewriters wtd rewriters') }++-- | Zonk a rewriter set; if a coercion hole in the set has been filled,+-- find all the free un-filled coercion holes in the coercion that fills it+zonkRewriterSet :: RewriterSet -> ZonkM RewriterSet+zonkRewriterSet (RewriterSet set)+  = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set+     -- This does not introduce non-determinism, because the only+     -- monadic action is to read, and the combining function is+     -- commutative+  where+    go :: CoercionHole -> ZonkM RewriterSet -> ZonkM RewriterSet+    go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc++    check_hole :: CoercionHole -> ZonkM RewriterSet+    check_hole hole+      = do { m_co <- unpackCoercionHole_maybe hole+           ; case m_co of+               Nothing -> return (unitRewriterSet hole)  -- Not filled+               Just co -> unUCHM (check_co co) }         -- Filled: look inside++    check_ty :: Type -> UnfilledCoercionHoleMonoid+    check_co :: Coercion -> UnfilledCoercionHoleMonoid+    (check_ty, _, check_co, _) = foldTyCo folder ()++    folder :: TyCoFolder () UnfilledCoercionHoleMonoid+    folder = TyCoFolder { tcf_view  = noView+                        , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv)+                        , tcf_covar = \ _ cv -> check_ty (varType cv)+                        , tcf_hole  = \ _ -> UCHM . check_hole+                        , tcf_tycobinder = \ _ _ _ -> () }++newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: ZonkM RewriterSet }++instance Semigroup UnfilledCoercionHoleMonoid where+  UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r)++instance Monoid UnfilledCoercionHoleMonoid where+  mempty = UCHM (return emptyRewriterSet)+++{-+************************************************************************+*                                                                      *+             Checking for coercion holes+*                                                                      *+************************************************************************+-}++-- | Is a coercion hole filled in?+isFilledCoercionHole :: CoercionHole -> ZonkM Bool+isFilledCoercionHole (CoercionHole { ch_ref = ref })+  = isJust <$> readTcRef ref++-- | Retrieve the contents of a coercion hole. Panics if the hole+-- is unfilled+unpackCoercionHole :: CoercionHole -> ZonkM Coercion+unpackCoercionHole hole+  = do { contents <- unpackCoercionHole_maybe hole+       ; case contents of+           Just co -> return co+           Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) }++-- | Retrieve the contents of a coercion hole, if it is filled+unpackCoercionHole_maybe :: CoercionHole -> ZonkM (Maybe Coercion)+unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref+++{-+%************************************************************************+%*                                                                      *                  Tidying *                                                                      * ************************************************************************@@ -586,6 +703,9 @@   = do { skol_info1 <- zonkSkolemInfoAnon skol_info        ; let skol_info2 = tidySkolemInfoAnon env skol_info1        ; return (env, GivenSCOrigin skol_info2 sc_depth blocked) }+zonkTidyOrigin env (ScOrigin (IsQC pred orig) nkd)+  = do { (env1, pred') <- zonkTidyTcType env pred+       ; return (env1, ScOrigin (IsQC pred' orig) nkd) } zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act                                       , uo_expected = exp })   = do { (env1, act') <- zonkTidyTcType env  act@@ -636,11 +756,18 @@   where     go zs env [] = return (env, reverse zs)     go zs env (FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig-                        , frr_info_not_concrete = mb_not_conc } : tys)+                        , frr_info_not_concrete = mb_not_conc+                        , frr_info_other_origin = mb_other_orig+                        } : tys)       = do { (env, ty) <- zonkTidyTcType env ty            ; (env, mb_not_conc) <- go_mb_not_conc env mb_not_conc+           ; (env, mb_other_orig) <-+               case mb_other_orig of+                 Nothing -> return (env, Nothing)+                 Just o  -> do { (env', o') <- zonkTidyOrigin env o; return (env', Just o') }            ; let info = FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig-                                 , frr_info_not_concrete = mb_not_conc }+                                 , frr_info_not_concrete = mb_not_conc+                                 , frr_info_other_origin = mb_other_orig }            ; go (info:zs) env tys }      go_mb_not_conc env Nothing = return (env, Nothing)@@ -658,7 +785,7 @@      -- NB: we do not tidy the ctev_evar field because we don't      --     show it in error messages tidyCtEvidence env ctev-  = ctev { ctev_pred = tidyOpenType env $ ctev_pred ctev }+  = setCtEvPredType ctev (tidyOpenType env (ctEvPred ctev))   -- tidyOpenType: for (beta ~ (forall a. a->a), don't gratuitously   -- rename the 'forall a' just because of an 'a' in scope somewhere   -- else entirely.@@ -673,6 +800,8 @@ tidyDelayedError :: TidyEnv -> DelayedError -> DelayedError tidyDelayedError env (DE_Hole hole)       = DE_Hole        $ tidyHole env hole tidyDelayedError env (DE_NotConcrete err) = DE_NotConcrete $ tidyConcreteError env err+tidyDelayedError env (DE_Multiplicity mult_co loc)+  = DE_Multiplicity (tidyCo env mult_co) loc  tidyConcreteError :: TidyEnv -> NotConcreteError -> NotConcreteError tidyConcreteError env err@(NCE_FRR { nce_frr_origin = frr_orig })
compiler/GHC/Tc/Zonk/Type.hs view
@@ -28,12 +28,6 @@         -- ** 'ZonkEnv', and the 'ZonkT' and 'ZonkBndrT' monad transformers         module GHC.Tc.Zonk.Env, -        -- * Coercion holes-        isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe,--        -- * Rewriter sets-        zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet,-         -- * Tidying         tcInitTidyEnv, tcInitOpenTidyEnv, @@ -55,7 +49,6 @@ import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr )-import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Errors.Types import GHC.Tc.Zonk.Env@@ -88,7 +81,6 @@ import GHC.Types.TypeEnv import GHC.Types.Basic import GHC.Types.SrcLoc-import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.TyThing @@ -99,8 +91,8 @@  import Control.Monad import Control.Monad.Trans.Class ( lift )-import Data.Semigroup import Data.List.NonEmpty ( NonEmpty )+import Data.Foldable ( toList )  {- Note [What is zonking?] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -380,7 +372,7 @@  zonkTyVarOcc :: HasDebugCallStack => TcTyVar -> ZonkTcM Type zonkTyVarOcc tv-  = do { ZonkEnv { ze_tv_env = tv_env } <- getZonkEnv+  = do { ZonkEnv { ze_tv_env = tv_env, ze_flexi = zonk_flexi } <- getZonkEnv         ; let lookup_in_tv_env    -- Look up in the env just as we do for Ids                = case lookupVarEnv tv_env tv of@@ -394,7 +386,7 @@               zonk_meta ref Flexi                = do { kind <- zonkTcTypeToTypeX (tyVarKind tv)-                    ; ty <- commitFlexi tv kind+                    ; ty <- lift $ commitFlexi zonk_flexi tv kind                      ; lift $ liftZonkM $ writeMetaTyVarRef tv ref ty  -- Belt and braces                     ; finish_meta ty }@@ -442,50 +434,47 @@                       Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env)        ; return res } -commitFlexi :: TcTyVar -> Kind -> ZonkTcM Type-commitFlexi tv zonked_kind-  = do { flexi <- ze_flexi <$> getZonkEnv-       ; lift $ case flexi of-         SkolemiseFlexi  -> return (mkTyVarTy (mkTyVar name zonked_kind))--         DefaultFlexi-             -- Normally, RuntimeRep variables are defaulted in GHC.Tc.Utils.TcMType.defaultTyVar-             -- But that sees only type variables that appear in, say, an inferred type.-             -- Defaulting here, in the zonker, is needed to catch e.g.-             --    y :: Bool-             --    y = (\x -> True) undefined-             -- We need *some* known RuntimeRep for the x and undefined, but no one-             -- will choose it until we get here, in the zonker.-           | isRuntimeRepTy zonked_kind-           -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)-                 ; return liftedRepTy }-           | isLevityTy zonked_kind-           -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv)-                 ; return liftedDataConTy }-           | isMultiplicityTy zonked_kind-           -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)-                 ; return manyDataConTy }-           | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv-           -> do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin)-                 ; return (anyTypeOfKind zonked_kind) }-           | otherwise-           -> do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv)-                   -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)-                 ; newZonkAnyType zonked_kind }--         RuntimeUnkFlexi-           -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)-                 ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) }-                           -- This is where RuntimeUnks are born:-                           -- otherwise-unconstrained unification variables are-                           -- turned into RuntimeUnks as they leave the-                           -- typechecker's monad+commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type+commitFlexi NoFlexi tv zonked_kind+  = pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) -         NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) }+commitFlexi (SkolemiseFlexi tvs_ref) tv zonked_kind+  = do { let skol_tv = mkTyVar (tyVarName tv) zonked_kind+       ; updTcRef tvs_ref (skol_tv :)+       ; return (mkTyVarTy skol_tv) } -  where-     name = tyVarName tv+commitFlexi RuntimeUnkFlexi tv zonked_kind+  = do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)+       ; return (mkTyVarTy (mkTcTyVar (tyVarName tv) zonked_kind RuntimeUnk)) }+            -- This is where RuntimeUnks are born:+            -- otherwise-unconstrained unification variables are+            -- turned into RuntimeUnks as they leave the+            -- typechecker's monad +commitFlexi DefaultFlexi tv zonked_kind+  -- Normally, RuntimeRep variables are defaulted in GHC.Tc.Utils.TcMType.defaultTyVar+  -- But that sees only type variables that appear in, say, an inferred type.+  -- Defaulting here, in the zonker, is needed to catch e.g.+  --    y :: Bool+  --    y = (\x -> True) undefined+  -- We need *some* known RuntimeRep for the x and undefined, but no one+  -- will choose it until we get here, in the zonker.+  | isRuntimeRepTy zonked_kind+  = do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)+       ; return liftedRepTy }+  | isLevityTy zonked_kind+  = do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv)+       ; return liftedDataConTy }+  | isMultiplicityTy zonked_kind+  = do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)+       ; return manyDataConTy }+  | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv+  = do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin)+       ; return (anyTypeOfKind zonked_kind) }+  | otherwise+  = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv)+          -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)+       ; newZonkAnyType zonked_kind }  zonkCoVarOcc :: CoVar -> ZonkTcM Coercion zonkCoVarOcc cv@@ -757,8 +746,12 @@     runZonkBndrT (zonkTyBndrsX    tyvars  ) $ \ new_tyvars   ->     runZonkBndrT (zonkEvBndrsX    evs     ) $ \ new_evs      ->     runZonkBndrT (zonkTcEvBinds_s ev_binds) $ \ new_ev_binds ->-  do { (new_val_bind, new_exports) <- mfix $ \ ~(new_val_binds, _) ->-       runZonkBndrT (extendIdZonkEnvRec $ collectHsBindsBinders CollNoDictBinders new_val_binds) $ \ _ ->+  do { (new_val_bind, new_exports) <- mfix $ \ ~(new_val_binds, new_exports) ->+       let new_bndrs = collectHsBindsBinders CollNoDictBinders new_val_binds+                       ++ map abe_poly new_exports+       -- Tie the knot with the `abe_poly` binders too, since they+       -- may be mentioned in the `abe_prags` of the `exports`+       in runZonkBndrT (extendIdZonkEnvRec new_bndrs) $ \ _ ->        do { new_val_binds <- mapM zonk_val_bind val_binds           ; new_exports   <- mapM zonk_export exports           ; return (new_val_binds, new_exports)@@ -815,20 +808,20 @@                        , psb_dir  = dir' } } }  zonkMultAnn :: HsMultAnn GhcTc -> ZonkTcM (HsMultAnn GhcTc)-zonkMultAnn (HsNoMultAnn mult)+zonkMultAnn (HsUnannotated mult)   = do { mult' <- zonkTcTypeToTypeX mult-       ; return (HsNoMultAnn mult') }-zonkMultAnn (HsPct1Ann mult)+       ; return (HsUnannotated mult') }+zonkMultAnn (HsLinearAnn mult)   = do { mult' <- zonkTcTypeToTypeX mult-       ; return (HsPct1Ann mult') }-zonkMultAnn (HsMultAnn mult hs_ty)+       ; return (HsLinearAnn mult') }+zonkMultAnn (HsExplicitMult mult hs_ty)   = do { mult' <- zonkTcTypeToTypeX mult-       ; return (HsMultAnn mult' hs_ty) }+       ; return (HsExplicitMult mult' hs_ty) }  zonkPatSynDetails :: HsPatSynDetails GhcTc                   -> ZonkTcM (HsPatSynDetails GhcTc)-zonkPatSynDetails (PrefixCon _ as)-  = PrefixCon noTypeArgs <$> traverse zonkLIdOcc as+zonkPatSynDetails (PrefixCon as)+  = PrefixCon <$> traverse zonkLIdOcc as zonkPatSynDetails (InfixCon a1 a2)   = InfixCon <$> zonkLIdOcc a1 <*> zonkLIdOcc a2 zonkPatSynDetails (RecCon flds)@@ -854,10 +847,27 @@   = mapM zonk_prag ps   where     zonk_prag (L loc (SpecPrag id co_fn inl))-        = do { co_fn' <- don'tBind $ zonkCoFn co_fn-             ; id' <- zonkIdOcc id-             ; return (L loc (SpecPrag id' co_fn' inl)) }+      = do { co_fn' <- don'tBind $ zonkCoFn co_fn+           ; id' <- zonkIdOcc id+           ; return (L loc (SpecPrag id' co_fn' inl)) }+    zonk_prag (L loc prag@(SpecPragE { spe_fn_id = poly_id+                                     , spe_bndrs = bndrs+                                     , spe_call  = spec_e }))+      = do { poly_id' <- zonkIdOcc poly_id +           ; skol_tvs_ref <- lift $ newTcRef []+           ; setZonkType (SkolemiseFlexi skol_tvs_ref) $+               -- SkolemiseFlexi: see Note [Free tyvars on rule LHS]++             runZonkBndrT (zonkCoreBndrsX bndrs)       $ \ bndrs' ->+             do { spec_e' <- zonkLExpr spec_e+                ; skol_tvs <- lift $ readTcRef skol_tvs_ref+                ; return (L loc (prag { spe_fn_id = poly_id'+                                      , spe_bndrs = skol_tvs ++ bndrs'+                                      , spe_call  = spec_e'+                                      }))+                }}+ {- ************************************************************************ *                                                                      *@@ -925,9 +935,9 @@   do { id' <- zonkIdOcc id      ; return (HsVar x (L l id')) } -zonkExpr (HsUnboundVar her occ)+zonkExpr (HsHole (h, her))   = do her' <- zonk_her her-       return (HsUnboundVar her' occ)+       return (HsHole (h, her'))   where     zonk_her :: HoleExprRef -> ZonkTcM HoleExprRef     zonk_her (HER ref ty u)@@ -935,14 +945,13 @@            ty'  <- zonkTcTypeToTypeX ty            return (HER ref ty' u) - zonkExpr (HsIPVar x _) = dataConCantHappen x  zonkExpr (HsOverLabel x _) = dataConCantHappen x -zonkExpr (HsLit x (HsRat e f ty))+zonkExpr (HsLit x (XLit (HsRat f ty)))   = do new_ty <- zonkTcTypeToTypeX ty-       return (HsLit x (HsRat e f new_ty))+       return (HsLit x (XLit $ HsRat f new_ty))  zonkExpr (HsLit x lit)   = return (HsLit x lit)@@ -1233,7 +1242,6 @@                          WpTyLam <$> zonkTyBndrX tv zonkCoFn (WpTyApp ty)  = WpTyApp <$> noBinders (zonkTcTypeToTypeX ty) zonkCoFn (WpLet bs)    = WpLet   <$> zonkTcEvBinds bs-zonkCoFn (WpMultCoercion co) = WpMultCoercion <$> noBinders (zonkCoToCo co)  ------------------------------------------------------------------------- zonkOverLit :: HsOverLit GhcTc -> ZonkTcM (HsOverLit GhcTc)@@ -1302,7 +1310,7 @@        ; new_stmts_w_bndrs <- noBinders $ mapM zonk_branch stmts_w_bndrs         -- Add in the binders after we're done with all the branches.-       ; let new_binders = [ b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs+       ; let new_binders = [ b | ParStmtBlock _ _ bs _ <- toList new_stmts_w_bndrs                            , b <- bs ]        ; extendIdZonkEnvRec new_binders        ; new_mzip <- noBinders $ zonkExpr mzip_op@@ -1440,7 +1448,7 @@     zonk_args args       = do { new_args_rev <- zonk_args_rev (reverse args)            ; new_pats     <- zonkPats (map get_pat args)-           ; return $ zipWithEqual "zonkStmt" replace_pat+           ; return $ zipWithEqual replace_pat                         new_pats (reverse new_args_rev) }       -- these need to go backward, because if any operators are higher-rank,@@ -1622,9 +1630,9 @@ --------------------------- zonkConStuff :: HsConPatDetails GhcTc              -> ZonkBndrTcM (HsConPatDetails GhcTc)-zonkConStuff (PrefixCon tyargs pats)+zonkConStuff (PrefixCon pats)   = do  { pats' <- zonkPats pats-        ; return (PrefixCon tyargs pats') }+        ; return (PrefixCon pats') }  zonkConStuff (InfixCon p1 p2)   = do  { p1' <- zonkPat p1@@ -1633,11 +1641,10 @@  zonkConStuff (RecCon (HsRecFields x rpats dd))   = do  { pats' <- zonkPats (map (hfbRHS . unLoc) rpats)-        ; x' <- mapM (noBinders . zonkCoToCo) x         ; let rpats' = zipWith (\(L l rp) p' ->                                   L l (rp { hfbRHS = p' }))                                rpats pats'-        ; return (RecCon (HsRecFields x' rpats' dd)) }+        ; return (RecCon (HsRecFields x rpats' dd)) }         -- Field selectors have declared types; hence no zonking  ---------------------------@@ -1672,31 +1679,74 @@ zonkRules rs = mapM (wrapLocZonkMA zonkRule) rs  zonkRule :: RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc)-zonkRule rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}+zonkRule rule@(HsRule { rd_bndrs = bndrs                       , rd_lhs = lhs                       , rd_rhs = rhs })-  = runZonkBndrT (traverse zonk_tm_bndr tm_bndrs) $ \ new_tm_bndrs ->-    do { -- See Note [Zonking the LHS of a RULE]-       ; new_lhs <- setZonkType SkolemiseFlexi $ zonkLExpr lhs-       ; new_rhs <-                              zonkLExpr rhs-       ; return $ rule { rd_tmvs = new_tm_bndrs-                       , rd_lhs  = new_lhs-                       , rd_rhs  = new_rhs } }+  = do { skol_tvs_ref <- lift $ newTcRef []+       ; setZonkType (SkolemiseFlexi skol_tvs_ref) $+           -- setZonkType: see Note [Free tyvars on rule LHS]+         zonkRuleBndrs bndrs $ \ new_bndrs ->+         do { new_lhs  <- zonkLExpr lhs+            ; skol_tvs <- lift $ readTcRef skol_tvs_ref+            ; new_rhs  <- setZonkType DefaultFlexi $ zonkLExpr rhs+            ; return $ rule { rd_bndrs = add_tvs skol_tvs new_bndrs+                            , rd_lhs   = new_lhs+                            , rd_rhs   = new_rhs } } }+   where+     add_tvs :: [TyVar] -> RuleBndrs GhcTc -> RuleBndrs GhcTc+     add_tvs tvs rbs@(RuleBndrs { rb_ext = bndrs }) = rbs { rb_ext = tvs ++ bndrs }+++zonkRuleBndrs :: RuleBndrs GhcTc -> (RuleBndrs GhcTc -> ZonkTcM a) -> ZonkTcM a+zonkRuleBndrs rb@(RuleBndrs { rb_ext = bndrs }) thing_inside+  = runZonkBndrT (traverse zonk_it bndrs) $ \ new_bndrs ->+    thing_inside (rb { rb_ext = new_bndrs })   where-   zonk_tm_bndr :: LRuleBndr GhcTc -> ZonkBndrTcM (LRuleBndr GhcTc)-   zonk_tm_bndr (L l (RuleBndr x (L loc v)))-      = do { v' <- zonk_it v-           ; return (L l (RuleBndr x (L loc v'))) }-   zonk_tm_bndr (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"+    zonk_it v+      | isId v     = zonkIdBndrX v+      | otherwise  = assert (isImmutableTyVar v) $+                     zonkTyBndrX v+                     -- We may need to go inside the kind of v and zonk there! -   zonk_it v-     | isId v     = zonkIdBndrX v-     | otherwise  = assert (isImmutableTyVar v)-                    zonkTyBndrX v-                    -- DV: used to be "return v", but that is plain-                    -- wrong because we may need to go inside the kind-                    -- of v and zonk there!+{- Note [Free tyvars on rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T a = C +  foo :: T a -> Int+  foo C = 1++  {-# RULES "myrule"  foo C = 1 #-}++After type checking the LHS becomes (foo alpha (C alpha)), where alpha+is an unbound meta-tyvar.  The zonker in GHC.Tc.Zonk.Type is careful not to+turn the free alpha into Any (as it usually does).  Instead we want to quantify+over it.   Here is how:++* We set the ze_flexi field of ZonkEnv to (SkolemiseFlexi ref), to tell the+  zonker to zonk a Flexi meta-tyvar to a TyVar, not to Any.  See the+  SkolemiseFlexi case of `commitFlexi`.++* Here (ref :: TcRef [TyVar]) collects the type variables thus skolemised;+  again see `commitFlexi`.++* When zonking a RULE, in `zonkRule` we+   - make a fresh ref-cell to collect the skolemised type variables,+   - zonk the binders and LHS with ze_flexi = SkolemiseFlexi ref+   - read the ref-cell to get all the skolemised TyVars+   - add them to the binders++All this applies for SPECIALISE pragmas too.++Wrinkles:++(FTV1) We just add the new tyvars to the front of the binder-list, but+  that may make the list not be in dependency order.  Example (T12925):+  the existing list is  [k:Type, b:k], and we add (a:k) to the front.+  Also we just collect the new skolemised type variables in any old order,+  so they may not be ordered with respect to each other.+-}+ {- ************************************************************************ *                                                                      *@@ -1902,89 +1952,3 @@ operation. (consider /\a -> f @ b, where b is side-effected to a) -} -{--************************************************************************-*                                                                      *-             Checking for coercion holes-*                                                                      *-************************************************************************--}---- | Is a coercion hole filled in?-isFilledCoercionHole :: CoercionHole -> TcM Bool-isFilledCoercionHole (CoercionHole { ch_ref = ref })-  = isJust <$> readTcRef ref---- | Retrieve the contents of a coercion hole. Panics if the hole--- is unfilled-unpackCoercionHole :: CoercionHole -> TcM Coercion-unpackCoercionHole hole-  = do { contents <- unpackCoercionHole_maybe hole-       ; case contents of-           Just co -> return co-           Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) }---- | Retrieve the contents of a coercion hole, if it is filled-unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)-unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref--zonkCtRewriterSet :: Ct -> TcM Ct-zonkCtRewriterSet ct-  | isGivenCt ct-  = return ct-  | otherwise-  = case ct of-      CEqCan eq@(EqCt { eq_ev = ev })       -> do { ev' <- zonkCtEvRewriterSet ev-                                                  ; return (CEqCan (eq { eq_ev = ev' })) }-      CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev-                                                  ; return (CIrredCan (ir { ir_ev = ev' })) }-      CDictCan di@(DictCt { di_ev = ev })   -> do { ev' <- zonkCtEvRewriterSet ev-                                                  ; return (CDictCan (di { di_ev = ev' })) }-      CQuantCan {}     -> return ct-      CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev-                             ; return (CNonCanonical ev') }--zonkCtEvRewriterSet :: CtEvidence -> TcM CtEvidence-zonkCtEvRewriterSet ev@(CtGiven {})-  = return ev-zonkCtEvRewriterSet ev@(CtWanted { ctev_rewriters = rewriters })-  = do { rewriters' <- zonkRewriterSet rewriters-       ; return (ev { ctev_rewriters = rewriters' }) }---- | Check whether any coercion hole in a RewriterSet is still unsolved.--- Does this by recursively looking through filled coercion holes until--- one is found that is not yet filled in, at which point this aborts.-zonkRewriterSet :: RewriterSet -> TcM RewriterSet-zonkRewriterSet (RewriterSet set)-  = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set-     -- this does not introduce non-determinism, because the only-     -- monadic action is to read, and the combining function is-     -- commutative-  where-    go :: CoercionHole -> TcM RewriterSet -> TcM RewriterSet-    go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc--    check_hole :: CoercionHole -> TcM RewriterSet-    check_hole hole = do { m_co <- unpackCoercionHole_maybe hole-                         ; case m_co of-                             Nothing -> return (unitRewriterSet hole)-                             Just co -> unUCHM (check_co co) }--    check_ty :: Type -> UnfilledCoercionHoleMonoid-    check_co :: Coercion -> UnfilledCoercionHoleMonoid-    (check_ty, _, check_co, _) = foldTyCo folder ()--    folder :: TyCoFolder () UnfilledCoercionHoleMonoid-    folder = TyCoFolder { tcf_view  = noView-                        , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv)-                        , tcf_covar = \ _ cv -> check_ty (varType cv)-                        , tcf_hole  = \ _ -> UCHM . check_hole-                        , tcf_tycobinder = \ _ _ _ -> () }--newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM RewriterSet }--instance Semigroup UnfilledCoercionHoleMonoid where-  UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r)--instance Monoid UnfilledCoercionHoleMonoid where-  mempty = UCHM (return emptyRewriterSet)
compiler/GHC/ThToHs.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -27,6 +28,7 @@  import GHC.Hs as Hs import GHC.Tc.Errors.Types+import GHC.Types.Name.Cache import GHC.Types.Name.Reader import qualified GHC.Types.Name as Name import GHC.Unit.Module@@ -47,11 +49,14 @@ import GHC.Data.FastString import GHC.Utils.Panic +import GHC.Data.EnumSet (EnumSet)+import qualified GHC.Data.EnumSet as EnumSet+import qualified GHC.LanguageExtensions as LangExt+ import Language.Haskell.Syntax.Basic (FieldLabelString(..))  import qualified Data.ByteString as BS-import Control.Monad( unless, ap )-import Control.Applicative( (<|>) )+import Control.Monad( unless ) import Data.Bifunctor (first) import Data.Foldable (for_) import Data.List.NonEmpty( NonEmpty (..), nonEmpty )@@ -63,32 +68,44 @@ import Foreign.Ptr import System.IO.Unsafe +import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict + ------------------------------------------------------------------- --              The external interface -convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs]-convertToHsDecls origin loc ds =-  initCvt origin loc $ fmap catMaybes (mapM cvt_dec ds)+convertToHsDecls :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs]+convertToHsDecls exts origin loc ds =+  initCvt exts origin loc $ fmap catMaybes (mapM cvt_dec ds)   where     cvt_dec d =       wrapMsg (ConvDec d) $ cvtDec d -convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs)-convertToHsExpr origin loc e-  = initCvt origin loc $ wrapMsg (ConvExp e) $ cvtl e+convertToHsExpr :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs)+convertToHsExpr exts origin loc e+  = initCvt exts origin loc $ wrapMsg (ConvExp e) $ cvtl e -convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs)-convertToPat origin loc p-  = initCvt origin loc $ wrapMsg (ConvPat p) $ cvtPat p+convertToPat :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs)+convertToPat exts origin loc p+  = initCvt exts origin loc $ wrapMsg (ConvPat p) $ cvtPat p -convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs)-convertToHsType origin loc t-  = initCvt origin loc $ wrapMsg (ConvType t) $ cvtType t+convertToHsType :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs)+convertToHsType exts origin loc t+  = initCvt exts origin loc $ wrapMsg (ConvType t) $ cvtType t  --------------------------------------------------------------------newtype CvtM' err a = CvtM { unCvtM :: Origin -> SrcSpan -> Either err (SrcSpan, a) }-    deriving (Functor)++-- Reader context for CvtM+data CvtCtx =+  CvtCtx { cvt_origin :: !Origin+         , cvt_listTuplePuns :: !Bool }++-- State of CvtM+type CvtSt = SrcSpan++newtype CvtM' err a = CvtM { unCvtM :: CvtCtx -> CvtSt -> Either err (a, SrcSpan) }+    deriving (Functor, Applicative, Monad) via ReaderT CvtCtx (StateT CvtSt (Either err))         -- Push down the Origin (that is configurable by         -- -fenable-th-splice-warnings) and source location;         -- Can fail, with a single error message@@ -103,21 +120,12 @@ -- Use the SrcSpan everywhere, for lack of anything better. -- See Note [Source locations within TH splices]. -instance Applicative (CvtM' err) where-    pure x = CvtM $ \_ loc -> Right (loc,x)-    (<*>) = ap--instance Monad (CvtM' err) where-  (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of-    Left err -> Left err-    Right (loc',v) -> unCvtM (k v) origin loc'- -- | Return first success or first error. -- -- Primary case should be the first because it -- would determine returned error message orOnFail :: CvtM' err a -> CvtM' err a -> CvtM' err a-(CvtM m1) `orOnFail` (CvtM m2) = CvtM $ \origin l -> choose (m1 origin l) (m2 origin l)+m1 `orOnFail` m2 = CvtM $ \ctx l -> choose (unCvtM m1 ctx l) (unCvtM m2 ctx l)   where     choose r@Right{}  _         = r     choose _          r@Right{} = r@@ -126,10 +134,13 @@ infixl 3 `orOnFail` -- The same fixity as for <|>  mapCvtMError :: (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a-mapCvtMError f (CvtM m) = CvtM $ \origin loc -> first f $ m origin loc+mapCvtMError f m = CvtM $ \origin loc -> first f $ unCvtM m origin loc -initCvt :: Origin -> SrcSpan -> CvtM' err a -> Either err a-initCvt origin loc (CvtM m) = fmap snd (m origin loc)+initCvt :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> CvtM' err a -> Either err a+initCvt exts origin loc m = fmap fst (unCvtM m ctx loc)+  where ctx = CvtCtx { cvt_origin = origin+                     , cvt_listTuplePuns = listTuplePuns }+        listTuplePuns = EnumSet.member LangExt.ListTuplePuns exts  force :: a -> CvtM () force a = a `seq` return ()@@ -138,42 +149,46 @@ failWith m = CvtM (\_ _ -> Left m)  getOrigin :: CvtM Origin-getOrigin = CvtM (\origin loc -> Right (loc,origin))+getOrigin = CvtM (\ctx s -> Right (cvt_origin ctx,s)) +getListTuplePuns :: CvtM Bool+getListTuplePuns = CvtM (\ctx s -> Right (cvt_listTuplePuns ctx,s))+ getL :: CvtM SrcSpan getL = CvtM (\_ loc -> Right (loc,loc))  -- NB: This is only used in conjunction with LineP pragmas. -- See Note [Source locations within TH splices]. setL :: SrcSpan -> CvtM ()-setL loc = CvtM (\_ _ -> Right (loc, ()))+setL loc = CvtM (\_ _ -> Right ((), loc))  returnLA :: (NoAnn ann) => e -> CvtM (LocatedAn ann e)-returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x))+returnLA x = CvtM (\_ loc -> Right (L (noAnnSrcSpan loc) x, loc))  returnJustLA :: a -> CvtM (Maybe (LocatedA a)) returnJustLA = fmap Just . returnLA  wrapParLA :: (NoAnn ann) => (LocatedAn ann a -> b) -> a -> CvtM b-wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x)))+wrapParLA add_par x = CvtM (\_ loc -> Right (add_par (L (noAnnSrcSpan loc) x), loc))  wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a wrapMsg what = mapCvtMError (ConversionFail what)  wrapL :: CvtM a -> CvtM (Located a)-wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of-  Left err -> Left err-  Right (loc', v) -> Right (loc', L loc v)+wrapL m = do+  loc <- getL+  fmap (L loc) m +wrapGL :: HasAnnotation e => CvtM a -> CvtM (GenLocated e a)+wrapGL m = do+  loc <- getL+  fmap (L (noAnnSrcSpan loc)) m+ wrapLN :: CvtM a -> CvtM (LocatedN a)-wrapLN (CvtM m) = CvtM $ \origin loc -> case m origin loc of-  Left err -> Left err-  Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)+wrapLN = wrapGL  wrapLA :: CvtM a -> CvtM (LocatedA a)-wrapLA (CvtM m) = CvtM $ \origin loc -> case m origin loc of-  Left err -> Left err-  Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)+wrapLA = wrapGL  {- Note [Source locations within TH splices]@@ -230,7 +245,7 @@           PatBind { pat_lhs = pat'                   , pat_rhs = GRHSs emptyComments body' ds'                   , pat_ext = noExtField-                  , pat_mult = HsNoMultAnn noExtField+                  , pat_mult = HsUnannotated EpPatBind                   } }  cvtDec (TH.FunD nm cls)@@ -452,7 +467,7 @@        ; returnJustLA $ Hs.ValD noExtField $ PatSynBind noExtField $            PSB noAnn nm' args' pat' dir' }   where-    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameN args+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameN args     cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2     cvtArgs (TH.RecordPatSyn sels)       = do { let mk_fld = fldNameN (nameBase nm)@@ -689,7 +704,7 @@ cvtConstr _ do_con_name (NormalC c strtys)   = do  { c'   <- do_con_name c         ; tys' <- mapM cvt_arg strtys-        ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) }+        ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon tys') }  cvtConstr parent_con do_con_name (RecC c varstrtys)   = do  { c'    <- do_con_name c@@ -702,7 +717,7 @@         ; st1' <- cvt_arg st1         ; st2' <- cvt_arg st2         ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing-                       (InfixCon (hsLinear st1') (hsLinear st2')) }+                       (InfixCon st1' st2') }  cvtConstr parent_con do_con_name (ForallC tvs ctxt con)   = do  { tvs'      <- cvtTvs tvs@@ -714,10 +729,15 @@     add_cxt (L loc cxt1) (Just (L _ cxt2))       = Just (L loc (cxt1 ++ cxt2)) +    -- Nested foralls end up flattened (see tests/th/GadtConSigs_th_dump1.stderr)+    -- but it doesn't seem to matter.     add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs                -> ConDecl GhcPs -> ConDecl GhcPs-    add_forall tvs' cxt' con@(ConDeclGADT { con_bndrs = L l outer_bndrs, con_mb_cxt = cxt })-      = con { con_bndrs  = L l outer_bndrs'+    add_forall tvs' cxt' con@(ConDeclGADT { con_outer_bndrs = L l outer_bndrs+                                          , con_inner_bndrs = inner_bndrs+                                          , con_mb_cxt = cxt })+      = con { con_outer_bndrs = L l outer_bndrs'+            , con_inner_bndrs = inner_bndrs             , con_mb_cxt = add_cxt cxt' cxt }       where         outer_bndrs'@@ -741,7 +761,7 @@         { c'      <- mapM do_con_name c         ; args    <- mapM cvt_arg strtys         ; ty'     <- cvtType ty-        ; mk_gadt_decl c' (PrefixConGADT noExtField $ map hsLinear args) ty'}+        ; mk_gadt_decl c' (PrefixConGADT noExtField args) ty'}  cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of     Nothing -> failWith RecGadtNoCons@@ -755,11 +775,12 @@ mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs              -> CvtM (LConDecl GhcPs) mk_gadt_decl names args res_ty-  = do bndrs <- returnLA mkHsOuterImplicit+  = do outer_bndrs <- returnLA mkHsOuterImplicit        returnLA $ ConDeclGADT                    { con_g_ext  = noAnn                    , con_names  = names-                   , con_bndrs  = bndrs+                   , con_outer_bndrs = outer_bndrs+                   , con_inner_bndrs = []                    , con_mb_cxt = Nothing                    , con_g_args = args                    , con_res_ty = res_ty@@ -775,25 +796,24 @@ cvtSrcStrictness SourceLazy         = SrcLazy cvtSrcStrictness SourceStrict       = SrcStrict -cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)+cvt_arg :: (TH.Bang, TH.Type) -> CvtM (HsConDeclField GhcPs) cvt_arg (Bang su ss, ty)   = do { ty'' <- cvtType ty        ; let ty' = parenthesizeHsType appPrec ty''              su' = cvtSrcUnpackedness su              ss' = cvtSrcStrictness ss-       ; returnLA $ HsBangTy (noAnn, NoSourceText) (HsBang su' ss') ty' }+       ; return $ CDF noAnn su' ss' (HsUnannotated (EpColon noAnn)) ty' Nothing }  cvt_id_arg :: TH.Name -- ^ parent constructor name-           -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)+           -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LHsConDeclRecField GhcPs) cvt_id_arg parent_con (i, str, ty)   = do  { L li i' <- fldNameN (nameBase parent_con) i         ; ty' <- cvt_arg (str,ty)-        ; returnLA $ ConDeclField-                          { cd_fld_ext = noAnn-                          , cd_fld_names+        ; returnLA $ HsConDeclRecField+                          { cdrf_ext = noExtField+                          , cdrf_names                               = [L (l2l li) $ FieldOcc noExtField (L li i')]-                          , cd_fld_type =  ty'-                          , cd_fld_doc = Nothing} }+                          , cdrf_spec = ty' } }  cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) cvtDerivs cs = do { mapM cvtDerivClause cs }@@ -895,31 +915,21 @@                     srcTxt = SourceText $ fsLit "{-# OPAQUE"        ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip } -cvtPragmaD (SpecialiseP nm ty inline phases)-  = do { nm' <- vNameN nm-       ; ty' <- cvtSigType ty-       ; let src TH.NoInline  = fsLit "{-# SPECIALISE NOINLINE"-             src TH.Inline    = fsLit "{-# SPECIALISE INLINE"-             src TH.Inlinable = fsLit "{-# SPECIALISE INLINE"-       ; let (inline', dflt, srcText) = case inline of-               Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,-                                toSrcTxt inline1)-               Nothing      -> (NoUserInlinePrag,   AlwaysActive,-                                SourceText $ fsLit "{-# SPECIALISE")-               where-                toSrcTxt a = SourceText $ src a-       ; let ip = InlinePragma { inl_src    = srcText-                               , inl_inline = inline'-                               , inl_rule   = Hs.FunLike-                               , inl_act    = cvtPhases phases dflt-                               , inl_sat    = Nothing }-       ; returnJustLA $ Hs.SigD noExtField $ SpecSig noAnn nm' [ty'] ip }- cvtPragmaD (SpecialiseInstP ty)   = do { ty' <- cvtSigType ty        ; returnJustLA $ Hs.SigD noExtField $          SpecInstSig (noAnn, (SourceText $ fsLit "{-# SPECIALISE")) ty' } +cvtPragmaD (SpecialiseEP ty_bndrs tm_bndrs exp inline phases)+  = do { ty_bndrs' <- traverse cvtTvs ty_bndrs+       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs+       ; let ip = cvtInlinePhases inline phases+       ; exp'      <- cvtl exp+       ; let bndrs' = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' }+       ; returnJustLA $ Hs.SigD noExtField $+           SpecSigE noAnn bndrs' exp' ip+       }+ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)   = do { let nm' = mkFastString nm        ; rd_name' <- returnLA nm'@@ -932,8 +942,7 @@                    HsRule { rd_ext  = (noAnn, quotedSourceText nm)                           , rd_name = rd_name'                           , rd_act  = act-                          , rd_tyvs = ty_bndrs'-                          , rd_tmvs = tm_bndrs'+                          , rd_bndrs = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' }                           , rd_lhs  = lhs'                           , rd_rhs  = rhs' }        ; returnJustLA $ Hs.RuleD noExtField@@ -1001,6 +1010,24 @@        ; ty' <- cvtType ty        ; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' } +cvtInlinePhases :: Maybe Inline -> Phases -> InlinePragma+cvtInlinePhases inline phases =+  let src TH.NoInline  = fsLit "{-# SPECIALISE NOINLINE"+      src TH.Inline    = fsLit "{-# SPECIALISE INLINE"+      src TH.Inlinable = fsLit "{-# SPECIALISE INLINE"+      (inline', dflt, srcText) = case inline of+        Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,+                         toSrcTxt inline1)+        Nothing      -> (NoUserInlinePrag,   AlwaysActive,+                         SourceText $ fsLit "{-# SPECIALISE")+        where+         toSrcTxt a = SourceText $ src a+  in InlinePragma { inl_src    = srcText+                  , inl_inline = inline'+                  , inl_rule   = Hs.FunLike+                  , inl_act    = cvtPhases phases dflt+                  , inl_sat    = Nothing }+ --------------------------------------------------- --              Declarations ---------------------------------------------------@@ -1043,8 +1070,8 @@ cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapLA (cvt e)   where-    cvt (VarE s)   = do { s' <- vName s; wrapParLA (HsVar noExtField) s' }-    cvt (ConE s)   = do { s' <- dName s; wrapParLA (HsVar noExtField) s' }+    cvt (VarE s)   = do { s' <- vName s; wrapParLA mkHsVar s' }+    cvt (ConE s)   = do { s' <- dName s; wrapParLA mkHsVar s' }     cvt (LitE l)       | overloadedLit l = go cvtOverLit (HsOverLit noExtField)                              (hsOverLitNeedsParens appPrec)@@ -1092,10 +1119,9 @@                                        ; return $ ExplicitSum noAnn alt arity e'}     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;                             ; return $ mkHsIf x' y' z' noAnn }-    cvt (MultiIfE alts)-      | null alts      = failWith MultiWayIfWithoutAlts-      | otherwise      = do { alts' <- mapM cvtpair alts-                            ; return $ HsMultiIf noAnn alts' }+    cvt (MultiIfE alts) = case nonEmpty alts of+        Nothing -> failWith MultiWayIfWithoutAlts+        Just alts -> HsMultiIf noAnn <$> traverse cvtpair alts     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs LetExpression ds                             ; e' <- cvtl e; return $ HsLet noAnn  ds' e'}     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms@@ -1170,7 +1196,7 @@                               -- important, because UnboundVarE may contain                               -- constructor names - see #14627.                               { s' <- vcName s-                              ; wrapParLA (HsVar noExtField) s' }+                              ; wrapParLA mkHsVar s' }     cvt (LabelE s)       = return $ HsOverLabel NoSourceText (fsLit s)     cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' }     cvt (GetFieldE exp f) = do { e' <- cvtl exp@@ -1179,7 +1205,7 @@     cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap                                          (DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString  . fsLit) xs     cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e-                              ; return $ HsTypedSplice noAnn e' }+                              ; return $ HsTypedSplice noExtField (HsTypedSpliceExpr noAnn e') }     cvt (TypedBracketE e) = do { e' <- cvtl e                                ; return $ HsTypedBracket noAnn e' }     cvt (TypeE t) = do { t' <- cvtType t@@ -1351,8 +1377,11 @@ cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' } cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs LetBinding ds                             ; returnLA $ LetStmt noAnn ds' }-cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss-                            ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr }+cvtStmt (TH.ParS dss)  = case nonEmpty dss of+    Nothing -> failWith EmptyParStmt+    Just dss -> do+      { dss' <- mapM cvt_one dss+      ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr }   where     cvt_one ds = do { ds' <- cvtStmts ds                     ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }@@ -1370,10 +1399,12 @@         ; decs' <- cvtLocalDecs WhereClause decs         ; returnLA $ Hs.Match noExtField ctxt (noLocA [lp]) (GRHSs emptyComments g' decs') } -cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]-cvtGuard (GuardedB pairs) = mapM cvtpair pairs+cvtGuard :: TH.Body -> CvtM (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))+cvtGuard (GuardedB pairs) = case nonEmpty pairs of+    Nothing -> failWith EmptyGuard+    Just pairs -> traverse cvtpair pairs cvtGuard (NormalB e)      = do { e' <- cvtl e-                               ; g' <- returnLA $ GRHS noAnn [] e'; return [g'] }+                               ; g' <- returnLA $ GRHS noAnn [] e'; return (g' :| []) }  cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs@@ -1471,14 +1502,12 @@                             ; unboxedSumChecks alt arity                             ; return $ SumPat noAnn p' alt arity } cvtp (ConP s ts ps)    = do { s' <- dNameN s-                            ; ps' <- cvtPats ps-                            ; ts' <- mapM cvtType ts+                            ; ps' <- cvtPats (map InvisP ts ++ ps)                             ; let pps = map (parenthesizePat appPrec) ps'-                                  pts = map (\t -> HsConPatTyArg noAnn (mkHsTyPat t)) ts'                             ; return $ ConPat                                 { pat_con_ext = noAnn                                 , pat_con = s'-                                , pat_args = PrefixCon pts pps+                                , pat_args = PrefixCon pps                                 }                             } cvtp (InfixP p1 s p2)  = do { s' <- dNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2@@ -1690,7 +1719,7 @@                           _            -> return $                                           parenthesizeHsType sigPrec x'                  let y'' = parenthesizeHsType sigPrec y'-                 returnLA (HsFunTy noExtField (HsUnrestrictedArrow noAnn) x'' y'')+                 returnLA (HsFunTy noExtField (HsUnannotated (EpArrow noAnn)) x'' y'')              | otherwise              -> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon                    ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' }@@ -1853,12 +1882,12 @@            _ -> failWith (MalformedType typeOrKind ty)     } -hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs+hsTypeToArrow :: LHsType GhcPs -> HsMultAnn GhcPs hsTypeToArrow w = case unLoc w of                      HsTyVar _ _ (L _ (isExact_maybe -> Just n))-                        | n == oneDataConName -> HsLinearArrow noAnn-                        | n == manyDataConName -> HsUnrestrictedArrow noAnn-                     _ -> HsExplicitMult noAnn w+                        | n == oneDataConName -> HsLinearAnn noAnn+                        | n == manyDataConName -> HsUnannotated (EpArrow noAnn)+                     _ -> HsExplicitMult (noAnn, EpArrow noAnn) w  -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only@@ -2165,7 +2194,8 @@   | not (okOcc ctxt_ns occ_str) = failWith (IllegalOccName ctxt_ns occ_str)   | otherwise   = do { loc <- getL-       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour+       ; listTuplePuns <- getListTuplePuns+       ; let rdr_name = thRdrName listTuplePuns loc ctxt_ns occ_str flavour        ; force rdr_name        ; return rdr_name }   where@@ -2185,7 +2215,7 @@       ""    -> False       (c:_) -> startsVarId c || startsVarSym c -thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName+thRdrName :: Bool -> SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- This turns a TH Name into a RdrName; used for both binders and occurrences -- See Note [Binders in Template Haskell] -- The passed-in name space tells what the context is expecting;@@ -2201,35 +2231,105 @@ --       which will give confusing error messages later -- -- The strict applications ensure that any buried exceptions get forced-thRdrName loc ctxt_ns th_occ th_name+thRdrName listTuplePuns loc ctxt_ns th_occ th_name   = case th_name of-     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod+     TH.NameG th_ns pkg mod -> thOrigOrExactRdrName th_occ th_ns pkg mod      TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ      TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)      TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc)-     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name-              | otherwise                           -> mkRdrUnqual $! occ-              -- We check for built-in syntax here, because the TH-              -- user might have written a (NameS "(,,)"), for example+     TH.NameS      -> thUnqualRdrName listTuplePuns occ   where     occ :: OccName.OccName     occ = mk_occ ctxt_ns th_occ --- Return an unqualified exact RdrName if we're dealing with built-in syntax.--- See #13776.+{- thOrigRdrName converts /original names/ in TH to their GHC representation.++An original name is the canonical (Module, OccName) pair (where Module also+includes package/unit info) that (a) uniquely and (b) unambiguously identifies a+top-level binding. For example, ghc-prim:GHC.Types.List is the original name of+the list type [].++To be more precise,+  a) "uniquely" means that there's exactly one original name for each top-level+     binding, which makes it different from a qualified name.+     Qualified names permit reexports and module aliases:++        import Data.List as L++        xs :: L.List a          -- L is a module alias for Data.List+        xs :: Data.List.List a  -- Data.List reexports GHC.Types.List++     Only ghc-prim:GHC.Types.List constitutes List's original name because+     GHC.Types is the original module where we find the type declaration:++        data List a = [] | a : List a   -- in ghc-prim:GHC.Types++  b) "unambiguously" means that the original name contains sufficient+     information to identify the top-level binding in all possible contexts.++     For example, ghc-prim:GHC.Types.List remains valid even if the user+     declares their own List type.++In TH, original names arise from name quotation, e.g.++   'Just      ==>   ghc-internal:GHC.Internal.Maybe.Just+  ''ReaderT   ==>   transformers:Control.Monad.Trans.Reader.ReaderT+  ''[]        ==>   ghc-prim:GHC.Types.List   (with ListTuplePuns)++NB. You likely want to use thOrigOrExactRdrName instead of thOrigRdrName.+-} thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName-thOrigRdrName occ th_ns pkg mod =-  let occ' = mk_occ (mk_ghc_ns th_ns) occ-      mod' = mkModule (mk_pkg pkg) (mk_mod mod)-  in case isBuiltInOcc_maybe occ' <|> isPunOcc_maybe mod' occ' of-       Just name -> nameRdrName name-       Nothing   -> (mkOrig $! mod') $! occ'+thOrigRdrName occ th_ns pkg mod = (mkOrig $! mod') $! occ'+  where+    occ' = mk_occ (mk_ghc_ns th_ns) occ+    mod' = mkModule (mk_pkg pkg) (mk_mod mod) -thRdrNameGuesses :: TH.Name -> [RdrName]-thRdrNameGuesses (TH.Name occ flavour)+{- Note [Pretty-printing known original names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An original name is a pair (Module, OccName), and normally we would pretty-print+it using the M.x syntax, e.g. "GHC.Types.Int" or "GHC.Internal.Base.ord".+However, this approach creates two problems (test case: th/T13776):++  1) Illegal quantification of built-in syntax, e.g. the nil data constructor []+     would be printed as GHC.Types.[], which is not valid Haskell syntax++  2) Ignoring ListTuplePuns. e.g. the type constructor (,) would be+     printed as GHC.Tuple.Tuple2, even though the user would prefer to see (,)++The pretty-printer for Name has special cases to deal with this, but the one for+Orig RdrNames does not. Trying to fix this directly in the Outputable RdrName instance+creates nasty module cycles. Instead, we work around the issue by avoiding the+problematic Orig names altogether, converting them to Exact names as early as+possible.+-}++-- thOrigOrExactRdrName is a variant of thOrigRdrName that returns Exact names+-- instead of known Orig names.+--+-- See Note [Pretty-printing known original names] for the rationale.+thOrigOrExactRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName+thOrigOrExactRdrName occ th_ns pkg mod = knownOrigToExactRdrName (thOrigRdrName occ th_ns pkg mod)++-- Convert known Orig names to Exact names, leaving all other names intact.+knownOrigToExactRdrName :: RdrName -> RdrName+knownOrigToExactRdrName (Orig mod occ)+  | Just name <- isKnownOrigName_maybe mod occ+  = Exact name+knownOrigToExactRdrName rdr = rdr++-- Return an exact RdrName if we're dealing with built-in syntax.+-- The user might have written (NameS "(,,)"), for example.+thUnqualRdrName :: Bool -> OccName.OccName -> RdrName+thUnqualRdrName listTuplePuns occ =+  case isBuiltInOcc_maybe listTuplePuns occ of+    Just name -> nameRdrName $! name+    Nothing   -> mkRdrUnqual $! occ++thRdrNameGuesses :: Bool -> TH.Name -> [RdrName]+thRdrNameGuesses listTuplePuns (TH.Name occ flavour)   -- This special case for NameG ensures that we don't generate duplicates in the output list-  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]-  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour+  | TH.NameG th_ns pkg mod <- flavour = [ thOrigOrExactRdrName occ_str th_ns pkg mod ]+  | otherwise                         = [ thRdrName listTuplePuns noSrcSpan gns occ_str flavour                                         | gns <- guessed_nss]   where     -- guessed_ns are the name spaces guessed from looking at the TH name
compiler/GHC/Unit/Finder.hs view
@@ -15,6 +15,7 @@     FinderCache(..),     initFinderCache,     findImportedModule,+    findImportedModuleWithIsBoot,     findPluginModule,     findExactModule,     findHomeModule,@@ -36,14 +37,14 @@  import GHC.Platform.Ways -import GHC.Builtin.Names ( gHC_PRIM )- import GHC.Data.OsPath  import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module import GHC.Unit.Home+import GHC.Unit.Home.Graph (UnitEnvGraph)+import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.State import GHC.Unit.Finder.Types @@ -55,6 +56,7 @@  import GHC.Linker.Types import GHC.Types.PkgQual+import GHC.Types.SourceFile  import GHC.Fingerprint import Data.IORef@@ -64,9 +66,9 @@ import Data.Time import qualified Data.Map as M import GHC.Driver.Env-    ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) ) import GHC.Driver.Config.Finder import qualified Data.Set as Set+import Data.List.NonEmpty ( NonEmpty (..) ) import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE @@ -86,26 +88,45 @@ -- ----------------------------------------------------------------------------- -- The finder's cache +{-+[Note: Monotonic addToFinderCache]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +addToFinderCache is only used by functions that return the cached value+if there is one, or by functions that always write an InstalledFound value.+Without multithreading it is then safe to always directly write the value+without checking the previously cached value.++However, with multithreading, it is possible that another function has+written a value into cache between the lookup and the addToFinderCache call.+in this case we should check to not overwrite an InstalledFound with an+InstalledNotFound.+-}+ initFinderCache :: IO FinderCache initFinderCache = do-  mod_cache <- newIORef emptyInstalledModuleWithIsBootEnv+  mod_cache <- newIORef emptyInstalledModuleEnv   file_cache <- newIORef M.empty   let flushFinderCaches :: UnitEnv -> IO ()       flushFinderCaches ue = do-        atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleWithIsBootEnv is_ext fm, ())+        atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())         atomicModifyIORef' file_cache $ \_ -> (M.empty, ())        where-        is_ext mod _ = not (isUnitEnvInstalledModule ue (gwib_mod mod))+        is_ext mod _ = not (isUnitEnvInstalledModule ue mod) -      addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()+      addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()       addToFinderCache key val =-        atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleWithIsBootEnv c key val, ())+        atomicModifyIORef' mod_cache $ \c ->+          case (lookupInstalledModuleEnv c key, val) of+            -- Don't overwrite an InstalledFound with an InstalledNotFound+            -- See [Note Monotonic addToFinderCache]+            (Just InstalledFound{}, InstalledNotFound{}) -> (c, ())+            _ -> (extendInstalledModuleEnv c key val, ()) -      lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)+      lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)       lookupFinderCache key = do          c <- readIORef mod_cache-         return $! lookupInstalledModuleWithIsBootEnv c key+         return $! lookupInstalledModuleEnv c key        lookupFileCache :: FilePath -> IO Fingerprint       lookupFileCache key = do@@ -137,6 +158,13 @@   in do     findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual +findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult+findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do+  res <- findImportedModule hsc_env mod pkg_qual+  case (res, is_boot) of+    (Found loc mod, IsBoot) -> return (Found (addBootSuffixLocn loc) mod)+    _ -> return res+ findImportedModuleNoHsc   :: FinderCache   -> FinderOpts@@ -176,7 +204,7 @@     -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as     -- that is not the same!! home_import is first because we need to look within ourselves     -- first before looking at the packages in order.-    any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)+    any_home_import = foldr1 orIfNotFound (home_import:| map home_pkg_import other_fopts)      pkg_import    = findExposedPackageModule fc fopts units  mod_name mb_pkg @@ -185,8 +213,8 @@                     findExposedPackageModule fc fopts units mod_name NoPkgQual      units     = case mhome_unit of-                  Nothing -> ue_units ue-                  Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue+                  Nothing -> ue_homeUnitState ue+                  Just home_unit -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue     hpt_deps :: [UnitId]     hpt_deps  = homeUnitDepends units     other_fopts  = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps@@ -195,30 +223,53 @@ -- plugin.  This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified.-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult-findPluginModule fc fopts units (Just home_unit) mod_name =+findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult+findPluginModuleNoHsc fc fopts units (Just home_unit) mod_name =   findHomeModule fc fopts home_unit mod_name   `orIfNotFound`   findExposedPluginPackageModule fc fopts units mod_name-findPluginModule fc fopts units Nothing mod_name =+findPluginModuleNoHsc fc fopts units Nothing mod_name =   findExposedPluginPackageModule fc fopts units mod_name --- | Locate a specific 'Module'.  The purpose of this function is to--- create a 'ModLocation' for a given 'Module', that is to find out--- where the files associated with this module live.  It is used when--- reading the interface for a module mentioned by another interface,--- for example (a "system import").+findPluginModule :: HscEnv -> ModuleName -> IO FindResult+findPluginModule hsc_env mod_name = do+  let fc = hsc_FC hsc_env+  let units = hsc_units hsc_env+  let mhome_unit = hsc_home_unit_maybe hsc_env+  findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name -findExactModule :: FinderCache -> FinderOpts ->  UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult-findExactModule fc fopts other_fopts unit_state mhome_unit mod = do-  case mhome_unit of++-- | A version of findExactModule which takes the exact parts of the HscEnv it needs+-- directly.+findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult+findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do+  res <- case mhome_unit of     Just home_unit      | isHomeInstalledModule home_unit mod         -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)-     | Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts+     | Just home_fopts <- HUG.unitEnv_lookup_maybe (moduleUnit mod) other_fopts         -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)     _ -> findPackageModule fc unit_state fopts mod+  case (res, is_boot) of+    (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc))+    _ -> return res ++-- | Locate a specific 'Module'.  The purpose of this function is to+-- create a 'ModLocation' for a given 'Module', that is to find out+-- where the files associated with this module live.  It is used when+-- reading the interface for a module mentioned by another interface,+-- for example (a "system import").+findExactModule :: HscEnv -> InstalledModule -> IsBootInterface -> IO InstalledFindResult+findExactModule hsc_env mod is_boot = do+  let dflags = hsc_dflags hsc_env+  let fc = hsc_FC hsc_env+  let unit_state = hsc_units hsc_env+  let home_unit = hsc_home_unit_maybe hsc_env+  let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)+  findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot++ -- ----------------------------------------------------------------------------- -- Helpers @@ -255,7 +306,7 @@ homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult homeSearchCache fc home_unit mod_name do_this = do   let mod = mkModule home_unit mod_name-  modLocationCache fc (notBoot mod) do_this+  modLocationCache fc mod do_this  findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult findExposedPackageModule fc fopts units mod_name mb_pkg =@@ -277,7 +328,7 @@         -- with just the location of the thing that was         -- instantiated; you probably also need all of the         -- implicit locations from the instances-        InstalledFound loc   _ -> return (Found loc m)+        InstalledFound loc     -> return (Found loc m)         InstalledNoPackage   _ -> return (NoPackage (moduleUnit m))         InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)                                          , fr_pkgs_hidden = []@@ -312,7 +363,7 @@                        , fr_unusables = []                        , fr_suggestions = suggest' }) -modLocationCache :: FinderCache -> InstalledModuleWithIsBoot -> IO InstalledFindResult -> IO InstalledFindResult+modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult modLocationCache fc mod do_this = do   m <- lookupFinderCache fc mod   case m of@@ -322,17 +373,19 @@         addToFinderCache fc mod result         return result -addModuleToFinder :: FinderCache -> ModuleWithIsBoot -> ModLocation -> IO ()-addModuleToFinder fc mod loc = do-  let imod = fmap toUnitId <$> mod-  addToFinderCache fc imod (InstalledFound loc (gwib_mod imod))+addModuleToFinder :: FinderCache -> Module -> ModLocation -> HscSource -> IO ()+addModuleToFinder fc mod loc src_flavour = do+  let imod = toUnitId <$> mod+  unless (src_flavour == HsBootFile) $+    addToFinderCache fc imod (InstalledFound loc)  -- This returns a module because it's more convenient for users-addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleNameWithIsBoot -> ModLocation -> IO Module-addHomeModuleToFinder fc home_unit mod_name loc = do-  let mod = mkHomeInstalledModule home_unit <$> mod_name-  addToFinderCache fc mod (InstalledFound loc (gwib_mod mod))-  return (mkHomeModule home_unit (gwib_mod mod_name))+addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> HscSource -> IO Module+addHomeModuleToFinder fc home_unit mod_name loc src_flavour = do+  let mod = mkHomeInstalledModule home_unit mod_name+  unless (src_flavour == HsBootFile) $+    addToFinderCache fc mod (InstalledFound loc)+  return (mkHomeModule home_unit mod_name)  -- ----------------------------------------------------------------------------- --      The internal workers@@ -342,7 +395,7 @@   let uid       = homeUnitAsUnit home_unit   r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name   return $ case r of-    InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)+    InstalledFound loc -> Found loc (mkHomeModule home_unit mod_name)     InstalledNoPackage _ -> NoPackage uid -- impossible     InstalledNotFound fps _ -> NotFound {         fr_paths = fmap unsafeDecodeUtf fps,@@ -367,7 +420,7 @@   let uid       = RealUnit (Definite home_unit)   r <- findInstalledHomeModule fc fopts home_unit mod_name   return $ case r of-    InstalledFound loc _ -> Found loc (mkModule uid mod_name)+    InstalledFound loc -> Found loc (mkModule uid mod_name)     InstalledNoPackage _ -> NoPackage uid -- impossible     InstalledNotFound fps _ -> NotFound {         fr_paths = fmap unsafeDecodeUtf fps,@@ -431,14 +484,7 @@      (search_dirs, exts)           | finder_lookupHomeInterfaces fopts = (hi_dir_path, hi_exts)           | otherwise                         = (home_path, source_exts)-   in--   -- special case for GHC.Prim; we won't find it in the filesystem.-   -- This is important only when compiling the base package (where GHC.Prim-   -- is a home module).-   if mod `installedModuleEq` gHC_PRIM-         then return (InstalledFound (error "GHC.Prim ModLocation") mod)-         else searchPathExts search_dirs mod exts+   in searchPathExts search_dirs mod exts  -- | Prepend the working directory to the search path. augmentImports :: OsPath -> [OsPath] -> [OsPath]@@ -466,13 +512,7 @@ findPackageModule_ fc fopts mod pkg_conf = do   massertPpr (moduleUnit mod == unitId pkg_conf)              (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))-  modLocationCache fc (notBoot mod) $--    -- special case for GHC.Prim; we won't find it in the filesystem.-    if mod `installedModuleEq` gHC_PRIM-          then return (InstalledFound (error "GHC.Prim ModLocation") mod)-          else-+  modLocationCache fc mod $     let        tag = waysBuildTag (finder_ways fopts) @@ -494,7 +534,7 @@             -- don't bother looking for it.             let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)                 loc = mk_hi_loc one basename-            in return $ InstalledFound loc mod+            in return $ InstalledFound loc       _otherwise ->             searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] @@ -528,7 +568,7 @@     search ((file, loc) : rest) = do       b <- doesFileExist file       if b-        then return $ InstalledFound loc mod+        then return $ InstalledFound loc         else search rest  mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt@@ -570,10 +610,12 @@ -- ext --      The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> ModLocation-mkHomeModLocation dflags mod src_filename =-   let (basename,extension) = OsPath.splitExtension src_filename-   in mkHomeModLocation2 dflags mod basename extension+mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> FileExt -> HscSource -> ModLocation+mkHomeModLocation dflags mod src_basename ext hsc_src =+   let loc = mkHomeModLocation2 dflags mod src_basename ext+   in case hsc_src of+     HsBootFile -> addBootSuffixLocnOut loc+     _ -> loc  mkHomeModLocation2 :: FinderOpts                    -> ModuleName
compiler/GHC/Utils/Touch.hs view
@@ -21,14 +21,8 @@     setFileTime hdl Nothing Nothing (Just t)     closeHandle hdl #else-#if MIN_VERSION_unix(2,8,0)   let oflags = defaultFileFlags { noctty = True, creat = Just 0o666 }   fd <- openFd file WriteOnly oflags-#else-  let oflags = defaultFileFlags { noctty = True }-  fd <- openFd file WriteOnly (Just 0o666) oflags-#endif   touchFd fd   closeFd fd #endif-
compiler/GHC/Utils/Unique.hs view
compiler/MachRegs.h view
@@ -222,7 +222,7 @@ /* define NO_ARG_REGS if we have no argument registers at all (we can  * optimise certain code paths using this predicate).  */-#if MAX_REAL_VANILLA_REG < 2+#if MAX_REAL_VANILLA_REG < 2 && MAX_REAL_XMM_REG == 0 #define NO_ARG_REGS #else #undef NO_ARG_REGS
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.12.3.20251228+version: 9.14.1.20251220 license: BSD-3-Clause license-file: LICENSE category: Development@@ -39,6 +39,8 @@     ghc-lib/stage0/compiler/build/primop-is-cheap.hs-incl     ghc-lib/stage0/compiler/build/primop-deprecations.hs-incl     ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs+    ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/Prim.hs+    ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/PrimopWrappers.hs     rts/include/stg/MachRegs/arm32.h     rts/include/stg/MachRegs/arm64.h     rts/include/stg/MachRegs/loongarch64.h@@ -75,14 +77,14 @@     if impl(ghc >= 8.8.1)         ghc-options: -fno-safe-haskell     if flag(threaded-rts)-        if impl(ghc < 9.12.3)+        if impl(ghc < 9.14.0)             ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS         else             ghc-options: -fobject-code -optc-DTHREADED_RTS         cc-options: -DTHREADED_RTS         cpp-options: -DTHREADED_RTS   -DBOOTSTRAP_TH     else-        if impl(ghc < 9.12.3)+        if impl(ghc < 9.14.0)            ghc-options: -fobject-code -package=ghc-boot-th         else            ghc-options: -fobject-code@@ -92,11 +94,11 @@     else         build-depends: Win32     build-depends:-        base >= 4.19 && < 4.22,+        base >= 4.20 && < 4.23,         ghc-prim > 0.2 && < 0.14,-        containers >= 0.6.2.1 && < 0.8,+        containers >= 0.6.2.1 && < 0.9,         bytestring >= 0.11.4 && < 0.13,-        time >= 1.4 && < 1.15,+        time >= 1.4 && < 1.16,         filepath >= 1.5 && < 1.6,         hpc >= 0.6 && < 0.8,         os-string >= 2.0.1 && < 2.1,@@ -113,7 +115,7 @@         semaphore-compat,         rts,         hpc >= 0.6 && < 0.8,-        ghc-lib-parser == 9.12.3.20251228+        ghc-lib-parser == 9.14.1.20251220     build-tool-depends: alex:alex >= 3.1, happy:happy == 1.20.* || == 2.0.2 || >= 2.1.2 && < 2.2     other-extensions:         BangPatterns@@ -152,6 +154,7 @@         MonoLocalBinds         NoImplicitPrelude     hs-source-dirs:+        ghc-lib/stage0/libraries/ghc-internal/build         ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build         compiler@@ -164,12 +167,15 @@         GHC.Boot.TH.PprLib,         GHC.Boot.TH.Syntax,         GHC.Builtin.Names,+        GHC.Builtin.Names.TH,         GHC.Builtin.PrimOps,         GHC.Builtin.PrimOps.Ids,         GHC.Builtin.Types,         GHC.Builtin.Types.Literals,         GHC.Builtin.Types.Prim,         GHC.Builtin.Uniques,+        GHC.Builtin.Utils,+        GHC.ByteCode.Breakpoints,         GHC.ByteCode.Types,         GHC.Cmm,         GHC.Cmm.BlockId,@@ -257,9 +263,13 @@         GHC.Data.FiniteMap,         GHC.Data.FlatBag,         GHC.Data.Graph.Directed,+        GHC.Data.Graph.Directed.Internal,+        GHC.Data.Graph.Directed.Reachability,         GHC.Data.Graph.UnVar,         GHC.Data.IOEnv,+        GHC.Data.List,         GHC.Data.List.Infinite,+        GHC.Data.List.NonEmpty,         GHC.Data.List.SetOps,         GHC.Data.Maybe,         GHC.Data.OrdList,@@ -298,6 +308,7 @@         GHC.Driver.Errors.Types,         GHC.Driver.Flags,         GHC.Driver.Hooks,+        GHC.Driver.IncludeSpecs,         GHC.Driver.LlvmConfigCache,         GHC.Driver.Monad,         GHC.Driver.Phases,@@ -340,19 +351,29 @@         GHC.Hs.Specificity,         GHC.Hs.Type,         GHC.Hs.Utils,+        GHC.HsToCore.Breakpoints,         GHC.HsToCore.Errors.Ppr,         GHC.HsToCore.Errors.Types,         GHC.HsToCore.Pmc.Ppr,         GHC.HsToCore.Pmc.Solver.Types,         GHC.HsToCore.Pmc.Types,+        GHC.HsToCore.Ticks,         GHC.Iface.Decl,         GHC.Iface.Errors.Ppr,         GHC.Iface.Errors.Types,         GHC.Iface.Ext.Fields,+        GHC.Iface.Flags,         GHC.Iface.Recomp.Binary,+        GHC.Iface.Recomp.Types,         GHC.Iface.Syntax,         GHC.Iface.Type,         GHC.Internal.ForeignSrcLang,+        GHC.Internal.Heap.Closures,+        GHC.Internal.Heap.Constants,+        GHC.Internal.Heap.InfoTable,+        GHC.Internal.Heap.InfoTable.Types,+        GHC.Internal.Heap.InfoTableProf,+        GHC.Internal.Heap.ProfInfo.Types,         GHC.Internal.LanguageExtensions,         GHC.Internal.Lexeme,         GHC.Internal.TH.Syntax,@@ -389,7 +410,7 @@         GHC.Platform.ARM,         GHC.Platform.ArchOS,         GHC.Platform.Constants,-        GHC.Platform.LoongArch64,+        GHC.Platform.LA64,         GHC.Platform.NoRegs,         GHC.Platform.PPC,         GHC.Platform.Profile,@@ -411,12 +432,13 @@         GHC.Runtime.Eval.Types,         GHC.Runtime.Heap.Layout,         GHC.Runtime.Interpreter.Types,+        GHC.Runtime.Interpreter.Types.SymbolCache,         GHC.Serialized,         GHC.Settings,         GHC.Settings.Config,         GHC.Settings.Constants,         GHC.Settings.Utils,-        GHC.Stg.InferTags.TagSig,+        GHC.Stg.EnforceEpt.TagSig,         GHC.Stg.Lift.Types,         GHC.Stg.Syntax,         GHC.StgToCmm.CgUtils,@@ -451,7 +473,6 @@         GHC.Types.Annotations,         GHC.Types.Avail,         GHC.Types.Basic,-        GHC.Types.Breakpoint,         GHC.Types.CompleteMatch,         GHC.Types.CostCentre,         GHC.Types.CostCentre.State,@@ -493,6 +514,7 @@         GHC.Types.SptEntry,         GHC.Types.SrcLoc,         GHC.Types.Target,+        GHC.Types.ThLevelIndex,         GHC.Types.Tickish,         GHC.Types.TyThing,         GHC.Types.TyThing.Ppr,@@ -516,7 +538,9 @@         GHC.Unit.External,         GHC.Unit.Finder.Types,         GHC.Unit.Home,+        GHC.Unit.Home.Graph,         GHC.Unit.Home.ModInfo,+        GHC.Unit.Home.PackageTable,         GHC.Unit.Info,         GHC.Unit.Module,         GHC.Unit.Module.Deps,@@ -527,7 +551,9 @@         GHC.Unit.Module.ModDetails,         GHC.Unit.Module.ModGuts,         GHC.Unit.Module.ModIface,+        GHC.Unit.Module.ModNodeKey,         GHC.Unit.Module.ModSummary,+        GHC.Unit.Module.Stage,         GHC.Unit.Module.Status,         GHC.Unit.Module.Warnings,         GHC.Unit.Module.WholeCoreBindings,@@ -574,10 +600,12 @@         Language.Haskell.Syntax,         Language.Haskell.Syntax.Basic,         Language.Haskell.Syntax.Binds,+        Language.Haskell.Syntax.BooleanFormula,         Language.Haskell.Syntax.Decls,         Language.Haskell.Syntax.Expr,         Language.Haskell.Syntax.Extension,         Language.Haskell.Syntax.ImpExp,+        Language.Haskell.Syntax.ImpExp.IsBoot,         Language.Haskell.Syntax.Lit,         Language.Haskell.Syntax.Module.Name,         Language.Haskell.Syntax.Pat,@@ -586,9 +614,7 @@     exposed-modules:         Paths_ghc_lib         GHC-        GHC.Builtin.Names.TH         GHC.Builtin.PrimOps.Casts-        GHC.Builtin.Utils         GHC.ByteCode.Asm         GHC.ByteCode.InfoTable         GHC.ByteCode.Instr@@ -639,6 +665,13 @@         GHC.CmmToAsm.Dwarf.Types         GHC.CmmToAsm.Format         GHC.CmmToAsm.Instr+        GHC.CmmToAsm.LA64+        GHC.CmmToAsm.LA64.CodeGen+        GHC.CmmToAsm.LA64.Cond+        GHC.CmmToAsm.LA64.Instr+        GHC.CmmToAsm.LA64.Ppr+        GHC.CmmToAsm.LA64.RegInfo+        GHC.CmmToAsm.LA64.Regs         GHC.CmmToAsm.Monad         GHC.CmmToAsm.PIC         GHC.CmmToAsm.PPC@@ -667,6 +700,7 @@         GHC.CmmToAsm.Reg.Linear.Base         GHC.CmmToAsm.Reg.Linear.FreeRegs         GHC.CmmToAsm.Reg.Linear.JoinToTargets+        GHC.CmmToAsm.Reg.Linear.LA64         GHC.CmmToAsm.Reg.Linear.PPC         GHC.CmmToAsm.Reg.Linear.RV64         GHC.CmmToAsm.Reg.Linear.StackMap@@ -721,6 +755,7 @@         GHC.Core.Opt.WorkWrap.Utils         GHC.Core.TyCon.Set         GHC.CoreToStg+        GHC.CoreToStg.AddImplicitBinds         GHC.CoreToStg.Prep         GHC.Data.Bitmap         GHC.Data.Graph.Base@@ -756,19 +791,22 @@         GHC.Driver.Config.StgToCmm         GHC.Driver.Config.StgToJS         GHC.Driver.Config.Tidy+        GHC.Driver.Downsweep         GHC.Driver.GenerateCgIPEStub         GHC.Driver.Main         GHC.Driver.Make+        GHC.Driver.MakeAction         GHC.Driver.MakeSem+        GHC.Driver.Messager         GHC.Driver.Pipeline         GHC.Driver.Pipeline.Execute         GHC.Driver.Pipeline.LogQueue+        GHC.Driver.Session.Inspect         GHC.Hs.Stats         GHC.Hs.Syn.Type         GHC.HsToCore         GHC.HsToCore.Arrows         GHC.HsToCore.Binds-        GHC.HsToCore.Breakpoints         GHC.HsToCore.Coverage         GHC.HsToCore.Docs         GHC.HsToCore.Expr@@ -791,7 +829,6 @@         GHC.HsToCore.Pmc.Solver         GHC.HsToCore.Pmc.Utils         GHC.HsToCore.Quote-        GHC.HsToCore.Ticks         GHC.HsToCore.Types         GHC.HsToCore.Usage         GHC.HsToCore.Utils@@ -856,10 +893,10 @@         GHC.Stg.BcPrep         GHC.Stg.CSE         GHC.Stg.Debug+        GHC.Stg.EnforceEpt+        GHC.Stg.EnforceEpt.Rewrite+        GHC.Stg.EnforceEpt.Types         GHC.Stg.FVs-        GHC.Stg.InferTags-        GHC.Stg.InferTags.Rewrite-        GHC.Stg.InferTags.Types         GHC.Stg.Lift         GHC.Stg.Lift.Analysis         GHC.Stg.Lift.Config@@ -915,7 +952,9 @@         GHC.StgToJS.Regs         GHC.StgToJS.Rts.Rts         GHC.StgToJS.Rts.Types-        GHC.StgToJS.Sinker+        GHC.StgToJS.Sinker.Collect+        GHC.StgToJS.Sinker.Sinker+        GHC.StgToJS.Sinker.StringsUnfloat         GHC.StgToJS.Stack         GHC.StgToJS.StaticPtr         GHC.StgToJS.Utils@@ -946,7 +985,6 @@         GHC.Tc.Gen.HsType         GHC.Tc.Gen.Match         GHC.Tc.Gen.Pat-        GHC.Tc.Gen.Rule         GHC.Tc.Gen.Sig         GHC.Tc.Gen.Splice         GHC.Tc.Instance.Class@@ -956,6 +994,7 @@         GHC.Tc.Module         GHC.Tc.Plugin         GHC.Tc.Solver+        GHC.Tc.Solver.Default         GHC.Tc.Solver.Dict         GHC.Tc.Solver.Equality         GHC.Tc.Solver.Irred@@ -968,7 +1007,6 @@         GHC.Tc.TyCl.Instance         GHC.Tc.TyCl.PatSyn         GHC.Tc.TyCl.Utils-        GHC.Tc.Types.EvTerm         GHC.Tc.Utils.Backpack         GHC.Tc.Utils.Concrete         GHC.Tc.Utils.Env
ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs view
@@ -84,6 +84,7 @@       pc_OFFSET_StgEntCounter_entry_count :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgUpdateFrame_NoHdr :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr :: {-# UNPACK #-} !Int,+      pc_SIZEOF_StgAnnFrame_NoHdr :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,       pc_OFFSET_StgMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,       pc_OFFSET_StgMutArrPtrs_size :: {-# UNPACK #-} !Int,@@ -168,7 +169,7 @@      ,v80,v81,v82,v83,v84,v85,v86,v87,v88,v89,v90,v91,v92,v93,v94,v95      ,v96,v97,v98,v99,v100,v101,v102,v103,v104,v105,v106,v107,v108,v109,v110,v111      ,v112,v113,v114,v115,v116,v117,v118,v119,v120,v121,v122,v123,v124,v125,v126,v127-     ,v128,v129,v130+     ,v128,v129,v130,v131      ] -> PlatformConstants             { pc_CONTROL_GROUP_CONST_291 = fromIntegral v0             , pc_STD_HDR_SIZE = fromIntegral v1@@ -250,57 +251,58 @@             , pc_OFFSET_StgEntCounter_entry_count = fromIntegral v77             , pc_SIZEOF_StgUpdateFrame_NoHdr = fromIntegral v78             , pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr = fromIntegral v79-            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v80-            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v81-            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v82-            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v83-            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v84-            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v85-            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v86-            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v87-            , pc_OFFSET_StgTSO_cccs = fromIntegral v88-            , pc_OFFSET_StgTSO_stackobj = fromIntegral v89-            , pc_OFFSET_StgStack_sp = fromIntegral v90-            , pc_OFFSET_StgStack_stack = fromIntegral v91-            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v92-            , pc_OFFSET_StgOrigThunkInfoFrame_info_ptr = fromIntegral v93-            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v94-            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v95-            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v96-            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v97-            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v98-            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v99-            , pc_MAX_SPEC_AP_SIZE = fromIntegral v100-            , pc_MIN_PAYLOAD_SIZE = fromIntegral v101-            , pc_MIN_INTLIKE = fromIntegral v102-            , pc_MAX_INTLIKE = fromIntegral v103-            , pc_MIN_CHARLIKE = fromIntegral v104-            , pc_MAX_CHARLIKE = fromIntegral v105-            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v106-            , pc_MAX_Vanilla_REG = fromIntegral v107-            , pc_MAX_Float_REG = fromIntegral v108-            , pc_MAX_Double_REG = fromIntegral v109-            , pc_MAX_Long_REG = fromIntegral v110-            , pc_MAX_XMM_REG = fromIntegral v111-            , pc_MAX_Real_Vanilla_REG = fromIntegral v112-            , pc_MAX_Real_Float_REG = fromIntegral v113-            , pc_MAX_Real_Double_REG = fromIntegral v114-            , pc_MAX_Real_XMM_REG = fromIntegral v115-            , pc_MAX_Real_Long_REG = fromIntegral v116-            , pc_RESERVED_C_STACK_BYTES = fromIntegral v117-            , pc_RESERVED_STACK_WORDS = fromIntegral v118-            , pc_AP_STACK_SPLIM = fromIntegral v119-            , pc_WORD_SIZE = fromIntegral v120-            , pc_CINT_SIZE = fromIntegral v121-            , pc_CLONG_SIZE = fromIntegral v122-            , pc_CLONG_LONG_SIZE = fromIntegral v123-            , pc_BITMAP_BITS_SHIFT = fromIntegral v124-            , pc_TAG_BITS = fromIntegral v125-            , pc_LDV_SHIFT = fromIntegral v126-            , pc_ILDV_CREATE_MASK = v127-            , pc_ILDV_STATE_CREATE = v128-            , pc_ILDV_STATE_USE = v129-            , pc_USE_INLINE_SRT_FIELD = 0 < v130+            , pc_SIZEOF_StgAnnFrame_NoHdr = fromIntegral v80+            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v81+            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v82+            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v83+            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v84+            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v85+            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v86+            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v87+            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v88+            , pc_OFFSET_StgTSO_cccs = fromIntegral v89+            , pc_OFFSET_StgTSO_stackobj = fromIntegral v90+            , pc_OFFSET_StgStack_sp = fromIntegral v91+            , pc_OFFSET_StgStack_stack = fromIntegral v92+            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v93+            , pc_OFFSET_StgOrigThunkInfoFrame_info_ptr = fromIntegral v94+            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v95+            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v96+            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v97+            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v98+            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v99+            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v100+            , pc_MAX_SPEC_AP_SIZE = fromIntegral v101+            , pc_MIN_PAYLOAD_SIZE = fromIntegral v102+            , pc_MIN_INTLIKE = fromIntegral v103+            , pc_MAX_INTLIKE = fromIntegral v104+            , pc_MIN_CHARLIKE = fromIntegral v105+            , pc_MAX_CHARLIKE = fromIntegral v106+            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v107+            , pc_MAX_Vanilla_REG = fromIntegral v108+            , pc_MAX_Float_REG = fromIntegral v109+            , pc_MAX_Double_REG = fromIntegral v110+            , pc_MAX_Long_REG = fromIntegral v111+            , pc_MAX_XMM_REG = fromIntegral v112+            , pc_MAX_Real_Vanilla_REG = fromIntegral v113+            , pc_MAX_Real_Float_REG = fromIntegral v114+            , pc_MAX_Real_Double_REG = fromIntegral v115+            , pc_MAX_Real_XMM_REG = fromIntegral v116+            , pc_MAX_Real_Long_REG = fromIntegral v117+            , pc_RESERVED_C_STACK_BYTES = fromIntegral v118+            , pc_RESERVED_STACK_WORDS = fromIntegral v119+            , pc_AP_STACK_SPLIM = fromIntegral v120+            , pc_WORD_SIZE = fromIntegral v121+            , pc_CINT_SIZE = fromIntegral v122+            , pc_CLONG_SIZE = fromIntegral v123+            , pc_CLONG_LONG_SIZE = fromIntegral v124+            , pc_BITMAP_BITS_SHIFT = fromIntegral v125+            , pc_TAG_BITS = fromIntegral v126+            , pc_LDV_SHIFT = fromIntegral v127+            , pc_ILDV_CREATE_MASK = v128+            , pc_ILDV_STATE_CREATE = v129+            , pc_ILDV_STATE_USE = v130+            , pc_USE_INLINE_SRT_FIELD = 0 < v131             }     _ -> error "Invalid platform constants" 
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -656,9 +656,6 @@    | ReadMVarOp    | TryReadMVarOp    | IsEmptyMVarOp-   | NewIOPortOp-   | ReadIOPortOp-   | WriteIOPortOp    | DelayOp    | WaitReadOp    | WaitWriteOp@@ -714,11 +711,13 @@    | GetCCSOfOp    | GetCurrentCCSOp    | ClearCCSOp+   | AnnotateStackOp    | WhereFromOp    | TraceEventOp    | TraceEventBinaryOp    | TraceMarkerOp    | SetThreadAllocationCounter+   | SetOtherThreadAllocationCounter    | VecBroadcastOp PrimOpVecCat Length Width    | VecPackOp PrimOpVecCat Length Width    | VecUnpackOp PrimOpVecCat Length Width
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -59,12 +59,16 @@   , (fsLit "bitReverse32#","Reverse the order of the bits in a 32-bit word.")   , (fsLit "bitReverse64#","Reverse the order of the bits in a 64-bit word.")   , (fsLit "bitReverse#","Reverse the order of the bits in a word.")+  , (fsLit "minDouble#","Return the minimum of the arguments.\n   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)\n   or one of the arguments is not-a-number (NaN),\n   it is unspecified which one is returned.")+  , (fsLit "maxDouble#","Return the maximum of the arguments.\n   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)\n   or one of the arguments is not-a-number (NaN),\n   it is unspecified which one is returned.")   , (fsLit "double2Int#","Truncates a 'Double#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")   , (fsLit "**##","Exponentiation.")   , (fsLit "decodeDouble_2Int#","Convert to integer.\n    First component of the result is -1 or 1, indicating the sign of the\n    mantissa. The next two are the high and low 32 bits of the mantissa\n    respectively, and the last is the exponent.")   , (fsLit "decodeDouble_Int64#","Decode 'Double#' into mantissa and base-2 exponent.")   , (fsLit "castDoubleToWord64#","Bitcast a 'Double#' into a 'Word64#'")   , (fsLit "castWord64ToDouble#","Bitcast a 'Word64#' into a 'Double#'")+  , (fsLit "minFloat#","Return the minimum of the arguments.\n   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)\n   or one of the arguments is not-a-number (NaN),\n   it is unspecified which one is returned.")+  , (fsLit "maxFloat#","Return the maximum of the arguments.\n   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)\n   or one of the arguments is not-a-number (NaN),\n   it is unspecified which one is returned.")   , (fsLit "float2Int#","Truncates a 'Float#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")   , (fsLit "decodeFloat_Int#","Convert to integers.\n    First 'Int#' in result is the mantissa; second is the exponent.")   , (fsLit "castFloatToWord32#","Bitcast a 'Float#' into a 'Word32#'")@@ -382,10 +386,6 @@   , (fsLit "readMVar#","If 'MVar#' is empty, block until it becomes full.\n   Then read its contents without modifying the MVar, without possibility\n   of intervention from other threads.")   , (fsLit "tryReadMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#'.")   , (fsLit "isEmptyMVar#","Return 1 if 'MVar#' is empty; 0 otherwise.")-  , (fsLit "IOPort#"," A shared I/O port is almost the same as an 'MVar#'.\n        The main difference is that IOPort has no deadlock detection or\n        deadlock breaking code that forcibly releases the lock. ")-  , (fsLit "newIOPort#","Create new 'IOPort#'; initially empty.")-  , (fsLit "readIOPort#","If 'IOPort#' is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.\n   Throws an 'IOPortException' if another thread is already\n   waiting to read this 'IOPort#'.")-  , (fsLit "writeIOPort#","If 'IOPort#' is full, immediately return with integer 0,\n    throwing an 'IOPortException'.\n    Otherwise, store value arg as 'IOPort#''s new contents,\n    and return with integer 1. ")   , (fsLit "delay#","Sleep specified number of microseconds.")   , (fsLit "waitRead#","Block until input is available on specified file descriptor.")   , (fsLit "waitWrite#","Block until output is possible on specified file descriptor.")@@ -425,6 +425,7 @@   , (fsLit "closureSize#"," @'closureSize#' closure@ returns the size of the given closure in\n     machine words. ")   , (fsLit "getCurrentCCS#"," Returns the current 'CostCentreStack' (value is @NULL@ if\n     not profiling).  Takes a dummy argument which can be used to\n     avoid the call to 'getCurrentCCS#' being floated out by the\n     simplifier, which would result in an uninformative stack\n     (\"CAF\"). ")   , (fsLit "clearCCS#"," Run the supplied IO action with an empty CCS.  For example, this\n     is used by the interpreter to run an interpreted computation\n     without the call stack showing that it was invoked from GHC. ")+  , (fsLit "annotateStack#"," Pushes an annotation frame to the stack which can be reported by backtraces. ")   , (fsLit "whereFrom#"," Fills the given buffer with the @InfoProvEnt@ for the info table of the\n     given object. Returns @1#@ on success and @0#@ otherwise.")   , (fsLit "FUN","The builtin function type, written in infix form as @a % m -> b@.\n   Values of this type are functions taking inputs of type @a@ and\n   producing outputs of type @b@. The multiplicity of the input is\n   @m@.\n\n   Note that @'FUN' m a b@ permits representation polymorphism in both\n   @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be\n   well-kinded.\n  ")   , (fsLit "realWorld#"," The token used in the implementation of the IO monad as a state monad.\n     It does not pass any information at runtime.\n     See also 'GHC.Magic.runRW#'. ")@@ -436,6 +437,7 @@   , (fsLit "traceBinaryEvent#"," Emits an event via the RTS tracing framework.  The contents\n     of the event is the binary object passed as the first argument with\n     the given length passed as the second argument. The event will be\n     emitted to the @.eventlog@ file. ")   , (fsLit "traceMarker#"," Emits a marker event via the RTS tracing framework.  The contents\n     of the event is the zero-terminated byte string passed as the first\n     argument.  The event will be emitted either to the @.eventlog@ file,\n     or to stderr, depending on the runtime RTS flags. ")   , (fsLit "setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ")+  , (fsLit "setOtherThreadAllocationCounter#"," Sets the allocation counter for the another thread to the given value.\n     This doesn't take allocations into the current nursery chunk into account.\n     Therefore it is only accurate if the other thread is not currently running. ")   , (fsLit "StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n     with a function in \"GHC.Stack.CloneStack\". Please check the\n     documentation in that module for more detailed explanations. ")   , (fsLit "coerce"," The function 'coerce' allows you to safely convert between values of\n     types that have the same representation with no run-time overhead. In the\n     simplest case you can use it instead of a newtype constructor, to go from\n     the newtype's concrete type to the abstract type. But it also works in\n     more complicated settings, e.g. converting a list of newtypes to a list of\n     concrete types.\n\n     When used in conversions involving a newtype wrapper,\n     make sure the newtype constructor is in scope.\n\n     This function is representation-polymorphic, but the\n     'RuntimeRep' type argument is marked as 'Inferred', meaning\n     that it is not available for visible type application. This means\n     the typechecker will accept @'coerce' \\@'Int' \\@Age 42@.\n\n     === __Examples__\n\n     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)\n     >>> newtype Age = Age Int deriving (Eq, Ord, Show)\n     >>> coerce (Age 42) :: TTL\n     TTL 42\n     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL\n     TTL 43\n     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]\n     [TTL 43,TTL 25]\n\n   ")   , (fsLit "broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ")@@ -498,66 +500,66 @@   , (fsLit "packDoubleX4#"," Pack the elements of an unboxed tuple into a vector. ")   , (fsLit "packFloatX16#"," Pack the elements of an unboxed tuple into a vector. ")   , (fsLit "packDoubleX8#"," Pack the elements of an unboxed tuple into a vector. ")-  , (fsLit "unpackInt8X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt16X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt32X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt64X2#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt8X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt16X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt32X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt64X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt8X64#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt16X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt32X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackInt64X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord8X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord16X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord32X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord64X2#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord8X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord16X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord32X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord64X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord8X64#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord16X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord32X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackWord64X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackFloatX4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackDoubleX2#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackFloatX8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackDoubleX4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackFloatX16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "unpackDoubleX8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , (fsLit "insertInt8X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt16X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt32X4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt64X2#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt8X32#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt16X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt32X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt64X4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt8X64#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt16X32#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt32X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertInt64X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord8X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord16X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord32X4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord64X2#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord8X32#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord16X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord32X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord64X4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord8X64#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord16X32#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord32X16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertWord64X8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertFloatX4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertDoubleX2#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertFloatX8#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertDoubleX4#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertFloatX16#"," Insert a scalar at the given position in a vector. ")-  , (fsLit "insertDoubleX8#"," Insert a scalar at the given position in a vector. ")+  , (fsLit "unpackInt8X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt16X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt32X4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt64X2#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt8X32#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt16X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt32X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt64X4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt8X64#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt16X32#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt32X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackInt64X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord8X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord16X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord32X4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord64X2#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord8X32#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord16X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord32X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord64X4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord8X64#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord16X32#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord32X16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackWord64X8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackFloatX4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackDoubleX2#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackFloatX8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackDoubleX4#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackFloatX16#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "unpackDoubleX8#"," Unpack the elements of a vector into an unboxed tuple. ")+  , (fsLit "insertInt8X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt16X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt32X4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt64X2#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt8X32#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt16X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt32X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt64X4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt8X64#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt16X32#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt32X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertInt64X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord8X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord16X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord32X4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord64X2#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord8X32#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord16X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord32X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord64X4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord8X64#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord16X32#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord32X16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertWord64X8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertFloatX4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertDoubleX2#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertFloatX8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertDoubleX4#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertFloatX16#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")+  , (fsLit "insertDoubleX8#"," Insert a scalar at the given position in a vector.\n     The position must be a compile-time constant. ")   , (fsLit "plusInt8X16#"," Add two vectors element-wise. ")   , (fsLit "plusInt16X8#"," Add two vectors element-wise. ")   , (fsLit "plusInt32X4#"," Add two vectors element-wise. ")@@ -654,54 +656,54 @@   , (fsLit "divideDoubleX4#"," Divide two vectors element-wise. ")   , (fsLit "divideFloatX16#"," Divide two vectors element-wise. ")   , (fsLit "divideDoubleX8#"," Divide two vectors element-wise. ")-  , (fsLit "quotInt8X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt16X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt32X4#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt64X2#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt8X32#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt16X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt32X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt64X4#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt8X64#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt16X32#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt32X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotInt64X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord8X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord16X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord32X4#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord64X2#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord8X32#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord16X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord32X8#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord64X4#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord8X64#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord16X32#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord32X16#"," Rounds towards zero element-wise. ")-  , (fsLit "quotWord64X8#"," Rounds towards zero element-wise. ")-  , (fsLit "remInt8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remInt64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , (fsLit "remWord64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , (fsLit "quotInt8X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt16X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt32X4#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt64X2#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt8X32#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt16X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt32X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt64X4#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt8X64#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt16X32#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt32X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotInt64X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord8X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord16X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord32X4#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord64X2#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord8X32#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord16X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord32X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord64X4#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord8X64#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord16X32#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord32X16#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "quotWord64X8#"," Rounds towards zero element-wise.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remInt64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")+  , (fsLit "remWord64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.\n\n     Note: Most CPU ISAs do not contain any SIMD integer division instructions.\n     Do not expect high performance. ")   , (fsLit "negateInt8X16#"," Negate element-wise. ")   , (fsLit "negateInt16X8#"," Negate element-wise. ")   , (fsLit "negateInt32X4#"," Negate element-wise. ")@@ -720,186 +722,186 @@   , (fsLit "negateDoubleX4#"," Negate element-wise. ")   , (fsLit "negateFloatX16#"," Negate element-wise. ")   , (fsLit "negateDoubleX8#"," Negate element-wise. ")-  , (fsLit "indexInt8X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt16X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt32X4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt64X2Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt8X32Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt16X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt32X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt64X4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt8X64Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt16X32Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt32X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexInt64X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord8X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord16X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord32X4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord64X2Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord8X32Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord16X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord32X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord64X4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord8X64Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord16X32Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord32X16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexWord64X8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexFloatX4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexDoubleX2Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexFloatX8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexDoubleX4Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexFloatX16Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "indexDoubleX8Array#"," Read a vector from specified index of immutable array. ")-  , (fsLit "readInt8X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt16X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt32X4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt64X2Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt8X32Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt16X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt32X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt64X4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt8X64Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt16X32Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt32X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readInt64X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord8X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord16X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord32X4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord64X2Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord8X32Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord16X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord32X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord64X4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord8X64Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord16X32Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord32X16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readWord64X8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readFloatX4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readDoubleX2Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readFloatX8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readDoubleX4Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readFloatX16Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "readDoubleX8Array#"," Read a vector from specified index of mutable array. ")-  , (fsLit "writeInt8X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt16X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt32X4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt64X2Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt8X32Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt16X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt32X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt64X4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt8X64Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt16X32Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt32X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeInt64X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord8X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord16X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord32X4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord64X2Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord8X32Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord16X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord32X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord64X4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord8X64Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord16X32Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord32X16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeWord64X8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeFloatX4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeDoubleX2Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeFloatX8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeDoubleX4Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeFloatX16Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "writeDoubleX8Array#"," Write a vector to specified index of mutable array. ")-  , (fsLit "indexInt8X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt16X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt32X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt64X2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt8X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt16X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt32X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt64X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt8X64OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt16X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt32X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexInt64X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord8X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord16X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord32X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord64X2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord8X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord16X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord32X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord64X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord8X64OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord16X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord32X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexWord64X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexFloatX4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexDoubleX2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexFloatX8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexDoubleX4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexFloatX16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "indexDoubleX8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt8X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt16X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt32X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt64X2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt8X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt16X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt32X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt64X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt8X64OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt16X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt32X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readInt64X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord8X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord16X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord32X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord64X2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord8X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord16X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord32X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord64X4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord8X64OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord16X32OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord32X16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readWord64X8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readFloatX4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readDoubleX2OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readFloatX8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readDoubleX4OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readFloatX16OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "readDoubleX8OffAddr#"," Reads vector; offset in bytes. ")-  , (fsLit "writeInt8X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt16X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt32X4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt64X2OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt8X32OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt16X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt32X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt64X4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt8X64OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt16X32OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt32X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeInt64X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord8X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord16X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord32X4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord64X2OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord8X32OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord16X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord32X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord64X4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord8X64OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord16X32OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord32X16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeWord64X8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeFloatX4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeDoubleX2OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeFloatX8OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeDoubleX4OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeFloatX16OffAddr#"," Write vector; offset in bytes. ")-  , (fsLit "writeDoubleX8OffAddr#"," Write vector; offset in bytes. ")+  , (fsLit "indexInt8X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X2Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X32Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X64Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X32Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X2Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X32Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X64Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X32Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX2Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX4Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX16Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX8Array#"," Read a vector from the specified index of an immutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X2Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X32Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X64Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X32Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X2Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X32Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X64Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X32Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX2Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX4Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX16Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX8Array#"," Read a vector from the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X2Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X32Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X64Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X32Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X2Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X32Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X64Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X32Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX2Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX4Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX16Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX8Array#"," Write a vector to the specified index of a mutable array.\n     The index is counted in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt8X64OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt16X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt32X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexInt64X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord8X64OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord16X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord32X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexWord64X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexFloatX16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "indexDoubleX8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt8X64OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt16X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt32X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readInt64X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord8X64OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord16X32OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord32X16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readWord64X8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX2OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX4OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readFloatX16OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "readDoubleX8OffAddr#"," Reads vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X2OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X32OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt8X64OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt16X32OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt32X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeInt64X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X2OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X32OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord8X64OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord16X32OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord32X16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeWord64X8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX2OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX4OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeFloatX16OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")+  , (fsLit "writeDoubleX8OffAddr#"," Write vector; offset in units of SIMD vectors (not scalar elements). ")   , (fsLit "indexInt8ArrayAsInt8X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")   , (fsLit "indexInt16ArrayAsInt16X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")   , (fsLit "indexInt32ArrayAsInt32X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")@@ -1104,36 +1106,36 @@   , (fsLit "fnmsubDoubleX4#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")   , (fsLit "fnmsubFloatX16#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")   , (fsLit "fnmsubDoubleX8#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")-  , (fsLit "shuffleInt8X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt16X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt32X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt64X2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt8X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt16X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt32X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt64X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt8X64#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt16X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt32X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleInt64X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord8X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord16X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord32X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord64X2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord8X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord16X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord32X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord64X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord8X64#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord16X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord32X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleWord64X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleFloatX4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleDoubleX2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleFloatX8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleDoubleX4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleFloatX16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")-  , (fsLit "shuffleDoubleX8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector.")+  , (fsLit "shuffleInt8X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt16X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt32X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt64X2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt8X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt16X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt32X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt64X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt8X64#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt16X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt32X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleInt64X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord8X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord16X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord32X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord64X2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord8X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord16X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord32X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord64X4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord8X64#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord16X32#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord32X16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleWord64X8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleFloatX4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleDoubleX2#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleFloatX8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleDoubleX4#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleFloatX16#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")+  , (fsLit "shuffleDoubleX8#","Shuffle elements of the concatenation of the input two vectors\n  into the result vector. The indices must be compile-time constants.")   , (fsLit "minInt8X16#","Component-wise minimum of two vectors.")   , (fsLit "minInt16X8#","Component-wise minimum of two vectors.")   , (fsLit "minInt32X4#","Component-wise minimum of two vectors.")
ghc-lib/stage0/compiler/build/primop-effects.hs-incl view
@@ -327,9 +327,6 @@ primOpEffect ReadMVarOp = ReadWriteEffect primOpEffect TryReadMVarOp = ReadWriteEffect primOpEffect IsEmptyMVarOp = ReadWriteEffect-primOpEffect NewIOPortOp = ReadWriteEffect-primOpEffect ReadIOPortOp = ReadWriteEffect-primOpEffect WriteIOPortOp = ReadWriteEffect primOpEffect DelayOp = ReadWriteEffect primOpEffect WaitReadOp = ReadWriteEffect primOpEffect WaitWriteOp = ReadWriteEffect@@ -374,6 +371,7 @@ primOpEffect TraceEventBinaryOp = ReadWriteEffect primOpEffect TraceMarkerOp = ReadWriteEffect primOpEffect SetThreadAllocationCounter = ReadWriteEffect+primOpEffect SetOtherThreadAllocationCounter = ReadWriteEffect primOpEffect (VecInsertOp _ _ _) = CanFail primOpEffect (VecDivOp _ _ _) = CanFail primOpEffect (VecQuotOp _ _ _) = CanFail
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -655,9 +655,6 @@    , ReadMVarOp    , TryReadMVarOp    , IsEmptyMVarOp-   , NewIOPortOp-   , ReadIOPortOp-   , WriteIOPortOp    , DelayOp    , WaitReadOp    , WaitWriteOp@@ -713,11 +710,13 @@    , GetCCSOfOp    , GetCurrentCCSOp    , ClearCCSOp+   , AnnotateStackOp    , WhereFromOp    , TraceEventOp    , TraceEventBinaryOp    , TraceMarkerOp    , SetThreadAllocationCounter+   , SetOtherThreadAllocationCounter    , (VecBroadcastOp IntVec 16 W8)    , (VecBroadcastOp IntVec 8 W16)    , (VecBroadcastOp IntVec 4 W32)
ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -62,9 +62,6 @@ primOpOutOfLine ReadMVarOp = True primOpOutOfLine TryReadMVarOp = True primOpOutOfLine IsEmptyMVarOp = True-primOpOutOfLine NewIOPortOp = True-primOpOutOfLine ReadIOPortOp = True-primOpOutOfLine WriteIOPortOp = True primOpOutOfLine DelayOp = True primOpOutOfLine WaitReadOp = True primOpOutOfLine WaitWriteOp = True@@ -106,9 +103,11 @@ primOpOutOfLine ClosureSizeOp = True primOpOutOfLine GetApStackValOp = True primOpOutOfLine ClearCCSOp = True+primOpOutOfLine AnnotateStackOp = True primOpOutOfLine WhereFromOp = True primOpOutOfLine TraceEventOp = True primOpOutOfLine TraceEventBinaryOp = True primOpOutOfLine TraceMarkerOp = True primOpOutOfLine SetThreadAllocationCounter = True+primOpOutOfLine SetOtherThreadAllocationCounter = True primOpOutOfLine _thisOp = False
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -655,9 +655,6 @@ primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy])) primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo NewIOPortOp = mkGenPrimOp (fsLit "newIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy levPolyAlphaTy]))-primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))-primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -713,11 +710,13 @@ primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVarSpec, alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo AnnotateStackOp = mkGenPrimOp (fsLit "annotateStack#")  [runtimeRep1TyVarInf, betaTyVarSpec, deltaTyVarSpec, openAlphaTyVarSpec] [betaTy, (mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, openAlphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, openAlphaTy])) primOpInfo WhereFromOp = mkGenPrimOp (fsLit "whereFrom#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [int64PrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo SetOtherThreadAllocationCounter = mkGenPrimOp (fsLit "setOtherThreadAllocationCounter#")  [] [int64PrimTy, threadIdPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [int8PrimTy] (int8X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [int16PrimTy] (int16X8PrimTy) primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [int32PrimTy] (int32X4PrimTy)
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1495 +1,1494 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1491-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 0-primOpTag CharGeOp = 1-primOpTag CharEqOp = 2-primOpTag CharNeOp = 3-primOpTag CharLtOp = 4-primOpTag CharLeOp = 5-primOpTag OrdOp = 6-primOpTag Int8ToIntOp = 7-primOpTag IntToInt8Op = 8-primOpTag Int8NegOp = 9-primOpTag Int8AddOp = 10-primOpTag Int8SubOp = 11-primOpTag Int8MulOp = 12-primOpTag Int8QuotOp = 13-primOpTag Int8RemOp = 14-primOpTag Int8QuotRemOp = 15-primOpTag Int8SllOp = 16-primOpTag Int8SraOp = 17-primOpTag Int8SrlOp = 18-primOpTag Int8ToWord8Op = 19-primOpTag Int8EqOp = 20-primOpTag Int8GeOp = 21-primOpTag Int8GtOp = 22-primOpTag Int8LeOp = 23-primOpTag Int8LtOp = 24-primOpTag Int8NeOp = 25-primOpTag Word8ToWordOp = 26-primOpTag WordToWord8Op = 27-primOpTag Word8AddOp = 28-primOpTag Word8SubOp = 29-primOpTag Word8MulOp = 30-primOpTag Word8QuotOp = 31-primOpTag Word8RemOp = 32-primOpTag Word8QuotRemOp = 33-primOpTag Word8AndOp = 34-primOpTag Word8OrOp = 35-primOpTag Word8XorOp = 36-primOpTag Word8NotOp = 37-primOpTag Word8SllOp = 38-primOpTag Word8SrlOp = 39-primOpTag Word8ToInt8Op = 40-primOpTag Word8EqOp = 41-primOpTag Word8GeOp = 42-primOpTag Word8GtOp = 43-primOpTag Word8LeOp = 44-primOpTag Word8LtOp = 45-primOpTag Word8NeOp = 46-primOpTag Int16ToIntOp = 47-primOpTag IntToInt16Op = 48-primOpTag Int16NegOp = 49-primOpTag Int16AddOp = 50-primOpTag Int16SubOp = 51-primOpTag Int16MulOp = 52-primOpTag Int16QuotOp = 53-primOpTag Int16RemOp = 54-primOpTag Int16QuotRemOp = 55-primOpTag Int16SllOp = 56-primOpTag Int16SraOp = 57-primOpTag Int16SrlOp = 58-primOpTag Int16ToWord16Op = 59-primOpTag Int16EqOp = 60-primOpTag Int16GeOp = 61-primOpTag Int16GtOp = 62-primOpTag Int16LeOp = 63-primOpTag Int16LtOp = 64-primOpTag Int16NeOp = 65-primOpTag Word16ToWordOp = 66-primOpTag WordToWord16Op = 67-primOpTag Word16AddOp = 68-primOpTag Word16SubOp = 69-primOpTag Word16MulOp = 70-primOpTag Word16QuotOp = 71-primOpTag Word16RemOp = 72-primOpTag Word16QuotRemOp = 73-primOpTag Word16AndOp = 74-primOpTag Word16OrOp = 75-primOpTag Word16XorOp = 76-primOpTag Word16NotOp = 77-primOpTag Word16SllOp = 78-primOpTag Word16SrlOp = 79-primOpTag Word16ToInt16Op = 80-primOpTag Word16EqOp = 81-primOpTag Word16GeOp = 82-primOpTag Word16GtOp = 83-primOpTag Word16LeOp = 84-primOpTag Word16LtOp = 85-primOpTag Word16NeOp = 86-primOpTag Int32ToIntOp = 87-primOpTag IntToInt32Op = 88-primOpTag Int32NegOp = 89-primOpTag Int32AddOp = 90-primOpTag Int32SubOp = 91-primOpTag Int32MulOp = 92-primOpTag Int32QuotOp = 93-primOpTag Int32RemOp = 94-primOpTag Int32QuotRemOp = 95-primOpTag Int32SllOp = 96-primOpTag Int32SraOp = 97-primOpTag Int32SrlOp = 98-primOpTag Int32ToWord32Op = 99-primOpTag Int32EqOp = 100-primOpTag Int32GeOp = 101-primOpTag Int32GtOp = 102-primOpTag Int32LeOp = 103-primOpTag Int32LtOp = 104-primOpTag Int32NeOp = 105-primOpTag Word32ToWordOp = 106-primOpTag WordToWord32Op = 107-primOpTag Word32AddOp = 108-primOpTag Word32SubOp = 109-primOpTag Word32MulOp = 110-primOpTag Word32QuotOp = 111-primOpTag Word32RemOp = 112-primOpTag Word32QuotRemOp = 113-primOpTag Word32AndOp = 114-primOpTag Word32OrOp = 115-primOpTag Word32XorOp = 116-primOpTag Word32NotOp = 117-primOpTag Word32SllOp = 118-primOpTag Word32SrlOp = 119-primOpTag Word32ToInt32Op = 120-primOpTag Word32EqOp = 121-primOpTag Word32GeOp = 122-primOpTag Word32GtOp = 123-primOpTag Word32LeOp = 124-primOpTag Word32LtOp = 125-primOpTag Word32NeOp = 126-primOpTag Int64ToIntOp = 127-primOpTag IntToInt64Op = 128-primOpTag Int64NegOp = 129-primOpTag Int64AddOp = 130-primOpTag Int64SubOp = 131-primOpTag Int64MulOp = 132-primOpTag Int64QuotOp = 133-primOpTag Int64RemOp = 134-primOpTag Int64SllOp = 135-primOpTag Int64SraOp = 136-primOpTag Int64SrlOp = 137-primOpTag Int64ToWord64Op = 138-primOpTag Int64EqOp = 139-primOpTag Int64GeOp = 140-primOpTag Int64GtOp = 141-primOpTag Int64LeOp = 142-primOpTag Int64LtOp = 143-primOpTag Int64NeOp = 144-primOpTag Word64ToWordOp = 145-primOpTag WordToWord64Op = 146-primOpTag Word64AddOp = 147-primOpTag Word64SubOp = 148-primOpTag Word64MulOp = 149-primOpTag Word64QuotOp = 150-primOpTag Word64RemOp = 151-primOpTag Word64AndOp = 152-primOpTag Word64OrOp = 153-primOpTag Word64XorOp = 154-primOpTag Word64NotOp = 155-primOpTag Word64SllOp = 156-primOpTag Word64SrlOp = 157-primOpTag Word64ToInt64Op = 158-primOpTag Word64EqOp = 159-primOpTag Word64GeOp = 160-primOpTag Word64GtOp = 161-primOpTag Word64LeOp = 162-primOpTag Word64LtOp = 163-primOpTag Word64NeOp = 164-primOpTag IntAddOp = 165-primOpTag IntSubOp = 166-primOpTag IntMulOp = 167-primOpTag IntMul2Op = 168-primOpTag IntMulMayOfloOp = 169-primOpTag IntQuotOp = 170-primOpTag IntRemOp = 171-primOpTag IntQuotRemOp = 172-primOpTag IntAndOp = 173-primOpTag IntOrOp = 174-primOpTag IntXorOp = 175-primOpTag IntNotOp = 176-primOpTag IntNegOp = 177-primOpTag IntAddCOp = 178-primOpTag IntSubCOp = 179-primOpTag IntGtOp = 180-primOpTag IntGeOp = 181-primOpTag IntEqOp = 182-primOpTag IntNeOp = 183-primOpTag IntLtOp = 184-primOpTag IntLeOp = 185-primOpTag ChrOp = 186-primOpTag IntToWordOp = 187-primOpTag IntToFloatOp = 188-primOpTag IntToDoubleOp = 189-primOpTag WordToFloatOp = 190-primOpTag WordToDoubleOp = 191-primOpTag IntSllOp = 192-primOpTag IntSraOp = 193-primOpTag IntSrlOp = 194-primOpTag WordAddOp = 195-primOpTag WordAddCOp = 196-primOpTag WordSubCOp = 197-primOpTag WordAdd2Op = 198-primOpTag WordSubOp = 199-primOpTag WordMulOp = 200-primOpTag WordMul2Op = 201-primOpTag WordQuotOp = 202-primOpTag WordRemOp = 203-primOpTag WordQuotRemOp = 204-primOpTag WordQuotRem2Op = 205-primOpTag WordAndOp = 206-primOpTag WordOrOp = 207-primOpTag WordXorOp = 208-primOpTag WordNotOp = 209-primOpTag WordSllOp = 210-primOpTag WordSrlOp = 211-primOpTag WordToIntOp = 212-primOpTag WordGtOp = 213-primOpTag WordGeOp = 214-primOpTag WordEqOp = 215-primOpTag WordNeOp = 216-primOpTag WordLtOp = 217-primOpTag WordLeOp = 218-primOpTag PopCnt8Op = 219-primOpTag PopCnt16Op = 220-primOpTag PopCnt32Op = 221-primOpTag PopCnt64Op = 222-primOpTag PopCntOp = 223-primOpTag Pdep8Op = 224-primOpTag Pdep16Op = 225-primOpTag Pdep32Op = 226-primOpTag Pdep64Op = 227-primOpTag PdepOp = 228-primOpTag Pext8Op = 229-primOpTag Pext16Op = 230-primOpTag Pext32Op = 231-primOpTag Pext64Op = 232-primOpTag PextOp = 233-primOpTag Clz8Op = 234-primOpTag Clz16Op = 235-primOpTag Clz32Op = 236-primOpTag Clz64Op = 237-primOpTag ClzOp = 238-primOpTag Ctz8Op = 239-primOpTag Ctz16Op = 240-primOpTag Ctz32Op = 241-primOpTag Ctz64Op = 242-primOpTag CtzOp = 243-primOpTag BSwap16Op = 244-primOpTag BSwap32Op = 245-primOpTag BSwap64Op = 246-primOpTag BSwapOp = 247-primOpTag BRev8Op = 248-primOpTag BRev16Op = 249-primOpTag BRev32Op = 250-primOpTag BRev64Op = 251-primOpTag BRevOp = 252-primOpTag Narrow8IntOp = 253-primOpTag Narrow16IntOp = 254-primOpTag Narrow32IntOp = 255-primOpTag Narrow8WordOp = 256-primOpTag Narrow16WordOp = 257-primOpTag Narrow32WordOp = 258-primOpTag DoubleGtOp = 259-primOpTag DoubleGeOp = 260-primOpTag DoubleEqOp = 261-primOpTag DoubleNeOp = 262-primOpTag DoubleLtOp = 263-primOpTag DoubleLeOp = 264-primOpTag DoubleMinOp = 265-primOpTag DoubleMaxOp = 266-primOpTag DoubleAddOp = 267-primOpTag DoubleSubOp = 268-primOpTag DoubleMulOp = 269-primOpTag DoubleDivOp = 270-primOpTag DoubleNegOp = 271-primOpTag DoubleFabsOp = 272-primOpTag DoubleToIntOp = 273-primOpTag DoubleToFloatOp = 274-primOpTag DoubleExpOp = 275-primOpTag DoubleExpM1Op = 276-primOpTag DoubleLogOp = 277-primOpTag DoubleLog1POp = 278-primOpTag DoubleSqrtOp = 279-primOpTag DoubleSinOp = 280-primOpTag DoubleCosOp = 281-primOpTag DoubleTanOp = 282-primOpTag DoubleAsinOp = 283-primOpTag DoubleAcosOp = 284-primOpTag DoubleAtanOp = 285-primOpTag DoubleSinhOp = 286-primOpTag DoubleCoshOp = 287-primOpTag DoubleTanhOp = 288-primOpTag DoubleAsinhOp = 289-primOpTag DoubleAcoshOp = 290-primOpTag DoubleAtanhOp = 291-primOpTag DoublePowerOp = 292-primOpTag DoubleDecode_2IntOp = 293-primOpTag DoubleDecode_Int64Op = 294-primOpTag CastDoubleToWord64Op = 295-primOpTag CastWord64ToDoubleOp = 296-primOpTag FloatGtOp = 297-primOpTag FloatGeOp = 298-primOpTag FloatEqOp = 299-primOpTag FloatNeOp = 300-primOpTag FloatLtOp = 301-primOpTag FloatLeOp = 302-primOpTag FloatMinOp = 303-primOpTag FloatMaxOp = 304-primOpTag FloatAddOp = 305-primOpTag FloatSubOp = 306-primOpTag FloatMulOp = 307-primOpTag FloatDivOp = 308-primOpTag FloatNegOp = 309-primOpTag FloatFabsOp = 310-primOpTag FloatToIntOp = 311-primOpTag FloatExpOp = 312-primOpTag FloatExpM1Op = 313-primOpTag FloatLogOp = 314-primOpTag FloatLog1POp = 315-primOpTag FloatSqrtOp = 316-primOpTag FloatSinOp = 317-primOpTag FloatCosOp = 318-primOpTag FloatTanOp = 319-primOpTag FloatAsinOp = 320-primOpTag FloatAcosOp = 321-primOpTag FloatAtanOp = 322-primOpTag FloatSinhOp = 323-primOpTag FloatCoshOp = 324-primOpTag FloatTanhOp = 325-primOpTag FloatAsinhOp = 326-primOpTag FloatAcoshOp = 327-primOpTag FloatAtanhOp = 328-primOpTag FloatPowerOp = 329-primOpTag FloatToDoubleOp = 330-primOpTag FloatDecode_IntOp = 331-primOpTag CastFloatToWord32Op = 332-primOpTag CastWord32ToFloatOp = 333-primOpTag FloatFMAdd = 334-primOpTag FloatFMSub = 335-primOpTag FloatFNMAdd = 336-primOpTag FloatFNMSub = 337-primOpTag DoubleFMAdd = 338-primOpTag DoubleFMSub = 339-primOpTag DoubleFNMAdd = 340-primOpTag DoubleFNMSub = 341-primOpTag NewArrayOp = 342-primOpTag ReadArrayOp = 343-primOpTag WriteArrayOp = 344-primOpTag SizeofArrayOp = 345-primOpTag SizeofMutableArrayOp = 346-primOpTag IndexArrayOp = 347-primOpTag UnsafeFreezeArrayOp = 348-primOpTag UnsafeThawArrayOp = 349-primOpTag CopyArrayOp = 350-primOpTag CopyMutableArrayOp = 351-primOpTag CloneArrayOp = 352-primOpTag CloneMutableArrayOp = 353-primOpTag FreezeArrayOp = 354-primOpTag ThawArrayOp = 355-primOpTag CasArrayOp = 356-primOpTag NewSmallArrayOp = 357-primOpTag ShrinkSmallMutableArrayOp_Char = 358-primOpTag ReadSmallArrayOp = 359-primOpTag WriteSmallArrayOp = 360-primOpTag SizeofSmallArrayOp = 361-primOpTag SizeofSmallMutableArrayOp = 362-primOpTag GetSizeofSmallMutableArrayOp = 363-primOpTag IndexSmallArrayOp = 364-primOpTag UnsafeFreezeSmallArrayOp = 365-primOpTag UnsafeThawSmallArrayOp = 366-primOpTag CopySmallArrayOp = 367-primOpTag CopySmallMutableArrayOp = 368-primOpTag CloneSmallArrayOp = 369-primOpTag CloneSmallMutableArrayOp = 370-primOpTag FreezeSmallArrayOp = 371-primOpTag ThawSmallArrayOp = 372-primOpTag CasSmallArrayOp = 373-primOpTag NewByteArrayOp_Char = 374-primOpTag NewPinnedByteArrayOp_Char = 375-primOpTag NewAlignedPinnedByteArrayOp_Char = 376-primOpTag MutableByteArrayIsPinnedOp = 377-primOpTag ByteArrayIsPinnedOp = 378-primOpTag ByteArrayIsWeaklyPinnedOp = 379-primOpTag MutableByteArrayIsWeaklyPinnedOp = 380-primOpTag ByteArrayContents_Char = 381-primOpTag MutableByteArrayContents_Char = 382-primOpTag ShrinkMutableByteArrayOp_Char = 383-primOpTag ResizeMutableByteArrayOp_Char = 384-primOpTag UnsafeFreezeByteArrayOp = 385-primOpTag UnsafeThawByteArrayOp = 386-primOpTag SizeofByteArrayOp = 387-primOpTag SizeofMutableByteArrayOp = 388-primOpTag GetSizeofMutableByteArrayOp = 389-primOpTag IndexByteArrayOp_Char = 390-primOpTag IndexByteArrayOp_WideChar = 391-primOpTag IndexByteArrayOp_Int = 392-primOpTag IndexByteArrayOp_Word = 393-primOpTag IndexByteArrayOp_Addr = 394-primOpTag IndexByteArrayOp_Float = 395-primOpTag IndexByteArrayOp_Double = 396-primOpTag IndexByteArrayOp_StablePtr = 397-primOpTag IndexByteArrayOp_Int8 = 398-primOpTag IndexByteArrayOp_Word8 = 399-primOpTag IndexByteArrayOp_Int16 = 400-primOpTag IndexByteArrayOp_Word16 = 401-primOpTag IndexByteArrayOp_Int32 = 402-primOpTag IndexByteArrayOp_Word32 = 403-primOpTag IndexByteArrayOp_Int64 = 404-primOpTag IndexByteArrayOp_Word64 = 405-primOpTag IndexByteArrayOp_Word8AsChar = 406-primOpTag IndexByteArrayOp_Word8AsWideChar = 407-primOpTag IndexByteArrayOp_Word8AsInt = 408-primOpTag IndexByteArrayOp_Word8AsWord = 409-primOpTag IndexByteArrayOp_Word8AsAddr = 410-primOpTag IndexByteArrayOp_Word8AsFloat = 411-primOpTag IndexByteArrayOp_Word8AsDouble = 412-primOpTag IndexByteArrayOp_Word8AsStablePtr = 413-primOpTag IndexByteArrayOp_Word8AsInt16 = 414-primOpTag IndexByteArrayOp_Word8AsWord16 = 415-primOpTag IndexByteArrayOp_Word8AsInt32 = 416-primOpTag IndexByteArrayOp_Word8AsWord32 = 417-primOpTag IndexByteArrayOp_Word8AsInt64 = 418-primOpTag IndexByteArrayOp_Word8AsWord64 = 419-primOpTag ReadByteArrayOp_Char = 420-primOpTag ReadByteArrayOp_WideChar = 421-primOpTag ReadByteArrayOp_Int = 422-primOpTag ReadByteArrayOp_Word = 423-primOpTag ReadByteArrayOp_Addr = 424-primOpTag ReadByteArrayOp_Float = 425-primOpTag ReadByteArrayOp_Double = 426-primOpTag ReadByteArrayOp_StablePtr = 427-primOpTag ReadByteArrayOp_Int8 = 428-primOpTag ReadByteArrayOp_Word8 = 429-primOpTag ReadByteArrayOp_Int16 = 430-primOpTag ReadByteArrayOp_Word16 = 431-primOpTag ReadByteArrayOp_Int32 = 432-primOpTag ReadByteArrayOp_Word32 = 433-primOpTag ReadByteArrayOp_Int64 = 434-primOpTag ReadByteArrayOp_Word64 = 435-primOpTag ReadByteArrayOp_Word8AsChar = 436-primOpTag ReadByteArrayOp_Word8AsWideChar = 437-primOpTag ReadByteArrayOp_Word8AsInt = 438-primOpTag ReadByteArrayOp_Word8AsWord = 439-primOpTag ReadByteArrayOp_Word8AsAddr = 440-primOpTag ReadByteArrayOp_Word8AsFloat = 441-primOpTag ReadByteArrayOp_Word8AsDouble = 442-primOpTag ReadByteArrayOp_Word8AsStablePtr = 443-primOpTag ReadByteArrayOp_Word8AsInt16 = 444-primOpTag ReadByteArrayOp_Word8AsWord16 = 445-primOpTag ReadByteArrayOp_Word8AsInt32 = 446-primOpTag ReadByteArrayOp_Word8AsWord32 = 447-primOpTag ReadByteArrayOp_Word8AsInt64 = 448-primOpTag ReadByteArrayOp_Word8AsWord64 = 449-primOpTag WriteByteArrayOp_Char = 450-primOpTag WriteByteArrayOp_WideChar = 451-primOpTag WriteByteArrayOp_Int = 452-primOpTag WriteByteArrayOp_Word = 453-primOpTag WriteByteArrayOp_Addr = 454-primOpTag WriteByteArrayOp_Float = 455-primOpTag WriteByteArrayOp_Double = 456-primOpTag WriteByteArrayOp_StablePtr = 457-primOpTag WriteByteArrayOp_Int8 = 458-primOpTag WriteByteArrayOp_Word8 = 459-primOpTag WriteByteArrayOp_Int16 = 460-primOpTag WriteByteArrayOp_Word16 = 461-primOpTag WriteByteArrayOp_Int32 = 462-primOpTag WriteByteArrayOp_Word32 = 463-primOpTag WriteByteArrayOp_Int64 = 464-primOpTag WriteByteArrayOp_Word64 = 465-primOpTag WriteByteArrayOp_Word8AsChar = 466-primOpTag WriteByteArrayOp_Word8AsWideChar = 467-primOpTag WriteByteArrayOp_Word8AsInt = 468-primOpTag WriteByteArrayOp_Word8AsWord = 469-primOpTag WriteByteArrayOp_Word8AsAddr = 470-primOpTag WriteByteArrayOp_Word8AsFloat = 471-primOpTag WriteByteArrayOp_Word8AsDouble = 472-primOpTag WriteByteArrayOp_Word8AsStablePtr = 473-primOpTag WriteByteArrayOp_Word8AsInt16 = 474-primOpTag WriteByteArrayOp_Word8AsWord16 = 475-primOpTag WriteByteArrayOp_Word8AsInt32 = 476-primOpTag WriteByteArrayOp_Word8AsWord32 = 477-primOpTag WriteByteArrayOp_Word8AsInt64 = 478-primOpTag WriteByteArrayOp_Word8AsWord64 = 479-primOpTag CompareByteArraysOp = 480-primOpTag CopyByteArrayOp = 481-primOpTag CopyMutableByteArrayOp = 482-primOpTag CopyMutableByteArrayNonOverlappingOp = 483-primOpTag CopyByteArrayToAddrOp = 484-primOpTag CopyMutableByteArrayToAddrOp = 485-primOpTag CopyAddrToByteArrayOp = 486-primOpTag CopyAddrToAddrOp = 487-primOpTag CopyAddrToAddrNonOverlappingOp = 488-primOpTag SetByteArrayOp = 489-primOpTag SetAddrRangeOp = 490-primOpTag AtomicReadByteArrayOp_Int = 491-primOpTag AtomicWriteByteArrayOp_Int = 492-primOpTag CasByteArrayOp_Int = 493-primOpTag CasByteArrayOp_Int8 = 494-primOpTag CasByteArrayOp_Int16 = 495-primOpTag CasByteArrayOp_Int32 = 496-primOpTag CasByteArrayOp_Int64 = 497-primOpTag FetchAddByteArrayOp_Int = 498-primOpTag FetchSubByteArrayOp_Int = 499-primOpTag FetchAndByteArrayOp_Int = 500-primOpTag FetchNandByteArrayOp_Int = 501-primOpTag FetchOrByteArrayOp_Int = 502-primOpTag FetchXorByteArrayOp_Int = 503-primOpTag AddrAddOp = 504-primOpTag AddrSubOp = 505-primOpTag AddrRemOp = 506-primOpTag AddrToIntOp = 507-primOpTag IntToAddrOp = 508-primOpTag AddrGtOp = 509-primOpTag AddrGeOp = 510-primOpTag AddrEqOp = 511-primOpTag AddrNeOp = 512-primOpTag AddrLtOp = 513-primOpTag AddrLeOp = 514-primOpTag IndexOffAddrOp_Char = 515-primOpTag IndexOffAddrOp_WideChar = 516-primOpTag IndexOffAddrOp_Int = 517-primOpTag IndexOffAddrOp_Word = 518-primOpTag IndexOffAddrOp_Addr = 519-primOpTag IndexOffAddrOp_Float = 520-primOpTag IndexOffAddrOp_Double = 521-primOpTag IndexOffAddrOp_StablePtr = 522-primOpTag IndexOffAddrOp_Int8 = 523-primOpTag IndexOffAddrOp_Word8 = 524-primOpTag IndexOffAddrOp_Int16 = 525-primOpTag IndexOffAddrOp_Word16 = 526-primOpTag IndexOffAddrOp_Int32 = 527-primOpTag IndexOffAddrOp_Word32 = 528-primOpTag IndexOffAddrOp_Int64 = 529-primOpTag IndexOffAddrOp_Word64 = 530-primOpTag IndexOffAddrOp_Word8AsChar = 531-primOpTag IndexOffAddrOp_Word8AsWideChar = 532-primOpTag IndexOffAddrOp_Word8AsInt = 533-primOpTag IndexOffAddrOp_Word8AsWord = 534-primOpTag IndexOffAddrOp_Word8AsAddr = 535-primOpTag IndexOffAddrOp_Word8AsFloat = 536-primOpTag IndexOffAddrOp_Word8AsDouble = 537-primOpTag IndexOffAddrOp_Word8AsStablePtr = 538-primOpTag IndexOffAddrOp_Word8AsInt16 = 539-primOpTag IndexOffAddrOp_Word8AsWord16 = 540-primOpTag IndexOffAddrOp_Word8AsInt32 = 541-primOpTag IndexOffAddrOp_Word8AsWord32 = 542-primOpTag IndexOffAddrOp_Word8AsInt64 = 543-primOpTag IndexOffAddrOp_Word8AsWord64 = 544-primOpTag ReadOffAddrOp_Char = 545-primOpTag ReadOffAddrOp_WideChar = 546-primOpTag ReadOffAddrOp_Int = 547-primOpTag ReadOffAddrOp_Word = 548-primOpTag ReadOffAddrOp_Addr = 549-primOpTag ReadOffAddrOp_Float = 550-primOpTag ReadOffAddrOp_Double = 551-primOpTag ReadOffAddrOp_StablePtr = 552-primOpTag ReadOffAddrOp_Int8 = 553-primOpTag ReadOffAddrOp_Word8 = 554-primOpTag ReadOffAddrOp_Int16 = 555-primOpTag ReadOffAddrOp_Word16 = 556-primOpTag ReadOffAddrOp_Int32 = 557-primOpTag ReadOffAddrOp_Word32 = 558-primOpTag ReadOffAddrOp_Int64 = 559-primOpTag ReadOffAddrOp_Word64 = 560-primOpTag ReadOffAddrOp_Word8AsChar = 561-primOpTag ReadOffAddrOp_Word8AsWideChar = 562-primOpTag ReadOffAddrOp_Word8AsInt = 563-primOpTag ReadOffAddrOp_Word8AsWord = 564-primOpTag ReadOffAddrOp_Word8AsAddr = 565-primOpTag ReadOffAddrOp_Word8AsFloat = 566-primOpTag ReadOffAddrOp_Word8AsDouble = 567-primOpTag ReadOffAddrOp_Word8AsStablePtr = 568-primOpTag ReadOffAddrOp_Word8AsInt16 = 569-primOpTag ReadOffAddrOp_Word8AsWord16 = 570-primOpTag ReadOffAddrOp_Word8AsInt32 = 571-primOpTag ReadOffAddrOp_Word8AsWord32 = 572-primOpTag ReadOffAddrOp_Word8AsInt64 = 573-primOpTag ReadOffAddrOp_Word8AsWord64 = 574-primOpTag WriteOffAddrOp_Char = 575-primOpTag WriteOffAddrOp_WideChar = 576-primOpTag WriteOffAddrOp_Int = 577-primOpTag WriteOffAddrOp_Word = 578-primOpTag WriteOffAddrOp_Addr = 579-primOpTag WriteOffAddrOp_Float = 580-primOpTag WriteOffAddrOp_Double = 581-primOpTag WriteOffAddrOp_StablePtr = 582-primOpTag WriteOffAddrOp_Int8 = 583-primOpTag WriteOffAddrOp_Word8 = 584-primOpTag WriteOffAddrOp_Int16 = 585-primOpTag WriteOffAddrOp_Word16 = 586-primOpTag WriteOffAddrOp_Int32 = 587-primOpTag WriteOffAddrOp_Word32 = 588-primOpTag WriteOffAddrOp_Int64 = 589-primOpTag WriteOffAddrOp_Word64 = 590-primOpTag WriteOffAddrOp_Word8AsChar = 591-primOpTag WriteOffAddrOp_Word8AsWideChar = 592-primOpTag WriteOffAddrOp_Word8AsInt = 593-primOpTag WriteOffAddrOp_Word8AsWord = 594-primOpTag WriteOffAddrOp_Word8AsAddr = 595-primOpTag WriteOffAddrOp_Word8AsFloat = 596-primOpTag WriteOffAddrOp_Word8AsDouble = 597-primOpTag WriteOffAddrOp_Word8AsStablePtr = 598-primOpTag WriteOffAddrOp_Word8AsInt16 = 599-primOpTag WriteOffAddrOp_Word8AsWord16 = 600-primOpTag WriteOffAddrOp_Word8AsInt32 = 601-primOpTag WriteOffAddrOp_Word8AsWord32 = 602-primOpTag WriteOffAddrOp_Word8AsInt64 = 603-primOpTag WriteOffAddrOp_Word8AsWord64 = 604-primOpTag InterlockedExchange_Addr = 605-primOpTag InterlockedExchange_Word = 606-primOpTag CasAddrOp_Addr = 607-primOpTag CasAddrOp_Word = 608-primOpTag CasAddrOp_Word8 = 609-primOpTag CasAddrOp_Word16 = 610-primOpTag CasAddrOp_Word32 = 611-primOpTag CasAddrOp_Word64 = 612-primOpTag FetchAddAddrOp_Word = 613-primOpTag FetchSubAddrOp_Word = 614-primOpTag FetchAndAddrOp_Word = 615-primOpTag FetchNandAddrOp_Word = 616-primOpTag FetchOrAddrOp_Word = 617-primOpTag FetchXorAddrOp_Word = 618-primOpTag AtomicReadAddrOp_Word = 619-primOpTag AtomicWriteAddrOp_Word = 620-primOpTag NewMutVarOp = 621-primOpTag ReadMutVarOp = 622-primOpTag WriteMutVarOp = 623-primOpTag AtomicSwapMutVarOp = 624-primOpTag AtomicModifyMutVar2Op = 625-primOpTag AtomicModifyMutVar_Op = 626-primOpTag CasMutVarOp = 627-primOpTag CatchOp = 628-primOpTag RaiseOp = 629-primOpTag RaiseUnderflowOp = 630-primOpTag RaiseOverflowOp = 631-primOpTag RaiseDivZeroOp = 632-primOpTag RaiseIOOp = 633-primOpTag MaskAsyncExceptionsOp = 634-primOpTag MaskUninterruptibleOp = 635-primOpTag UnmaskAsyncExceptionsOp = 636-primOpTag MaskStatus = 637-primOpTag NewPromptTagOp = 638-primOpTag PromptOp = 639-primOpTag Control0Op = 640-primOpTag AtomicallyOp = 641-primOpTag RetryOp = 642-primOpTag CatchRetryOp = 643-primOpTag CatchSTMOp = 644-primOpTag NewTVarOp = 645-primOpTag ReadTVarOp = 646-primOpTag ReadTVarIOOp = 647-primOpTag WriteTVarOp = 648-primOpTag NewMVarOp = 649-primOpTag TakeMVarOp = 650-primOpTag TryTakeMVarOp = 651-primOpTag PutMVarOp = 652-primOpTag TryPutMVarOp = 653-primOpTag ReadMVarOp = 654-primOpTag TryReadMVarOp = 655-primOpTag IsEmptyMVarOp = 656-primOpTag NewIOPortOp = 657-primOpTag ReadIOPortOp = 658-primOpTag WriteIOPortOp = 659-primOpTag DelayOp = 660-primOpTag WaitReadOp = 661-primOpTag WaitWriteOp = 662-primOpTag ForkOp = 663-primOpTag ForkOnOp = 664-primOpTag KillThreadOp = 665-primOpTag YieldOp = 666-primOpTag MyThreadIdOp = 667-primOpTag LabelThreadOp = 668-primOpTag IsCurrentThreadBoundOp = 669-primOpTag NoDuplicateOp = 670-primOpTag GetThreadLabelOp = 671-primOpTag ThreadStatusOp = 672-primOpTag ListThreadsOp = 673-primOpTag MkWeakOp = 674-primOpTag MkWeakNoFinalizerOp = 675-primOpTag AddCFinalizerToWeakOp = 676-primOpTag DeRefWeakOp = 677-primOpTag FinalizeWeakOp = 678-primOpTag TouchOp = 679-primOpTag MakeStablePtrOp = 680-primOpTag DeRefStablePtrOp = 681-primOpTag EqStablePtrOp = 682-primOpTag MakeStableNameOp = 683-primOpTag StableNameToIntOp = 684-primOpTag CompactNewOp = 685-primOpTag CompactResizeOp = 686-primOpTag CompactContainsOp = 687-primOpTag CompactContainsAnyOp = 688-primOpTag CompactGetFirstBlockOp = 689-primOpTag CompactGetNextBlockOp = 690-primOpTag CompactAllocateBlockOp = 691-primOpTag CompactFixupPointersOp = 692-primOpTag CompactAdd = 693-primOpTag CompactAddWithSharing = 694-primOpTag CompactSize = 695-primOpTag ReallyUnsafePtrEqualityOp = 696-primOpTag ParOp = 697-primOpTag SparkOp = 698-primOpTag GetSparkOp = 699-primOpTag NumSparks = 700-primOpTag KeepAliveOp = 701-primOpTag DataToTagSmallOp = 702-primOpTag DataToTagLargeOp = 703-primOpTag TagToEnumOp = 704-primOpTag AddrToAnyOp = 705-primOpTag AnyToAddrOp = 706-primOpTag MkApUpd0_Op = 707-primOpTag NewBCOOp = 708-primOpTag UnpackClosureOp = 709-primOpTag ClosureSizeOp = 710-primOpTag GetApStackValOp = 711-primOpTag GetCCSOfOp = 712-primOpTag GetCurrentCCSOp = 713-primOpTag ClearCCSOp = 714-primOpTag WhereFromOp = 715-primOpTag TraceEventOp = 716-primOpTag TraceEventBinaryOp = 717-primOpTag TraceMarkerOp = 718-primOpTag SetThreadAllocationCounter = 719-primOpTag (VecBroadcastOp IntVec 16 W8) = 720-primOpTag (VecBroadcastOp IntVec 8 W16) = 721-primOpTag (VecBroadcastOp IntVec 4 W32) = 722-primOpTag (VecBroadcastOp IntVec 2 W64) = 723-primOpTag (VecBroadcastOp IntVec 32 W8) = 724-primOpTag (VecBroadcastOp IntVec 16 W16) = 725-primOpTag (VecBroadcastOp IntVec 8 W32) = 726-primOpTag (VecBroadcastOp IntVec 4 W64) = 727-primOpTag (VecBroadcastOp IntVec 64 W8) = 728-primOpTag (VecBroadcastOp IntVec 32 W16) = 729-primOpTag (VecBroadcastOp IntVec 16 W32) = 730-primOpTag (VecBroadcastOp IntVec 8 W64) = 731-primOpTag (VecBroadcastOp WordVec 16 W8) = 732-primOpTag (VecBroadcastOp WordVec 8 W16) = 733-primOpTag (VecBroadcastOp WordVec 4 W32) = 734-primOpTag (VecBroadcastOp WordVec 2 W64) = 735-primOpTag (VecBroadcastOp WordVec 32 W8) = 736-primOpTag (VecBroadcastOp WordVec 16 W16) = 737-primOpTag (VecBroadcastOp WordVec 8 W32) = 738-primOpTag (VecBroadcastOp WordVec 4 W64) = 739-primOpTag (VecBroadcastOp WordVec 64 W8) = 740-primOpTag (VecBroadcastOp WordVec 32 W16) = 741-primOpTag (VecBroadcastOp WordVec 16 W32) = 742-primOpTag (VecBroadcastOp WordVec 8 W64) = 743-primOpTag (VecBroadcastOp FloatVec 4 W32) = 744-primOpTag (VecBroadcastOp FloatVec 2 W64) = 745-primOpTag (VecBroadcastOp FloatVec 8 W32) = 746-primOpTag (VecBroadcastOp FloatVec 4 W64) = 747-primOpTag (VecBroadcastOp FloatVec 16 W32) = 748-primOpTag (VecBroadcastOp FloatVec 8 W64) = 749-primOpTag (VecPackOp IntVec 16 W8) = 750-primOpTag (VecPackOp IntVec 8 W16) = 751-primOpTag (VecPackOp IntVec 4 W32) = 752-primOpTag (VecPackOp IntVec 2 W64) = 753-primOpTag (VecPackOp IntVec 32 W8) = 754-primOpTag (VecPackOp IntVec 16 W16) = 755-primOpTag (VecPackOp IntVec 8 W32) = 756-primOpTag (VecPackOp IntVec 4 W64) = 757-primOpTag (VecPackOp IntVec 64 W8) = 758-primOpTag (VecPackOp IntVec 32 W16) = 759-primOpTag (VecPackOp IntVec 16 W32) = 760-primOpTag (VecPackOp IntVec 8 W64) = 761-primOpTag (VecPackOp WordVec 16 W8) = 762-primOpTag (VecPackOp WordVec 8 W16) = 763-primOpTag (VecPackOp WordVec 4 W32) = 764-primOpTag (VecPackOp WordVec 2 W64) = 765-primOpTag (VecPackOp WordVec 32 W8) = 766-primOpTag (VecPackOp WordVec 16 W16) = 767-primOpTag (VecPackOp WordVec 8 W32) = 768-primOpTag (VecPackOp WordVec 4 W64) = 769-primOpTag (VecPackOp WordVec 64 W8) = 770-primOpTag (VecPackOp WordVec 32 W16) = 771-primOpTag (VecPackOp WordVec 16 W32) = 772-primOpTag (VecPackOp WordVec 8 W64) = 773-primOpTag (VecPackOp FloatVec 4 W32) = 774-primOpTag (VecPackOp FloatVec 2 W64) = 775-primOpTag (VecPackOp FloatVec 8 W32) = 776-primOpTag (VecPackOp FloatVec 4 W64) = 777-primOpTag (VecPackOp FloatVec 16 W32) = 778-primOpTag (VecPackOp FloatVec 8 W64) = 779-primOpTag (VecUnpackOp IntVec 16 W8) = 780-primOpTag (VecUnpackOp IntVec 8 W16) = 781-primOpTag (VecUnpackOp IntVec 4 W32) = 782-primOpTag (VecUnpackOp IntVec 2 W64) = 783-primOpTag (VecUnpackOp IntVec 32 W8) = 784-primOpTag (VecUnpackOp IntVec 16 W16) = 785-primOpTag (VecUnpackOp IntVec 8 W32) = 786-primOpTag (VecUnpackOp IntVec 4 W64) = 787-primOpTag (VecUnpackOp IntVec 64 W8) = 788-primOpTag (VecUnpackOp IntVec 32 W16) = 789-primOpTag (VecUnpackOp IntVec 16 W32) = 790-primOpTag (VecUnpackOp IntVec 8 W64) = 791-primOpTag (VecUnpackOp WordVec 16 W8) = 792-primOpTag (VecUnpackOp WordVec 8 W16) = 793-primOpTag (VecUnpackOp WordVec 4 W32) = 794-primOpTag (VecUnpackOp WordVec 2 W64) = 795-primOpTag (VecUnpackOp WordVec 32 W8) = 796-primOpTag (VecUnpackOp WordVec 16 W16) = 797-primOpTag (VecUnpackOp WordVec 8 W32) = 798-primOpTag (VecUnpackOp WordVec 4 W64) = 799-primOpTag (VecUnpackOp WordVec 64 W8) = 800-primOpTag (VecUnpackOp WordVec 32 W16) = 801-primOpTag (VecUnpackOp WordVec 16 W32) = 802-primOpTag (VecUnpackOp WordVec 8 W64) = 803-primOpTag (VecUnpackOp FloatVec 4 W32) = 804-primOpTag (VecUnpackOp FloatVec 2 W64) = 805-primOpTag (VecUnpackOp FloatVec 8 W32) = 806-primOpTag (VecUnpackOp FloatVec 4 W64) = 807-primOpTag (VecUnpackOp FloatVec 16 W32) = 808-primOpTag (VecUnpackOp FloatVec 8 W64) = 809-primOpTag (VecInsertOp IntVec 16 W8) = 810-primOpTag (VecInsertOp IntVec 8 W16) = 811-primOpTag (VecInsertOp IntVec 4 W32) = 812-primOpTag (VecInsertOp IntVec 2 W64) = 813-primOpTag (VecInsertOp IntVec 32 W8) = 814-primOpTag (VecInsertOp IntVec 16 W16) = 815-primOpTag (VecInsertOp IntVec 8 W32) = 816-primOpTag (VecInsertOp IntVec 4 W64) = 817-primOpTag (VecInsertOp IntVec 64 W8) = 818-primOpTag (VecInsertOp IntVec 32 W16) = 819-primOpTag (VecInsertOp IntVec 16 W32) = 820-primOpTag (VecInsertOp IntVec 8 W64) = 821-primOpTag (VecInsertOp WordVec 16 W8) = 822-primOpTag (VecInsertOp WordVec 8 W16) = 823-primOpTag (VecInsertOp WordVec 4 W32) = 824-primOpTag (VecInsertOp WordVec 2 W64) = 825-primOpTag (VecInsertOp WordVec 32 W8) = 826-primOpTag (VecInsertOp WordVec 16 W16) = 827-primOpTag (VecInsertOp WordVec 8 W32) = 828-primOpTag (VecInsertOp WordVec 4 W64) = 829-primOpTag (VecInsertOp WordVec 64 W8) = 830-primOpTag (VecInsertOp WordVec 32 W16) = 831-primOpTag (VecInsertOp WordVec 16 W32) = 832-primOpTag (VecInsertOp WordVec 8 W64) = 833-primOpTag (VecInsertOp FloatVec 4 W32) = 834-primOpTag (VecInsertOp FloatVec 2 W64) = 835-primOpTag (VecInsertOp FloatVec 8 W32) = 836-primOpTag (VecInsertOp FloatVec 4 W64) = 837-primOpTag (VecInsertOp FloatVec 16 W32) = 838-primOpTag (VecInsertOp FloatVec 8 W64) = 839-primOpTag (VecAddOp IntVec 16 W8) = 840-primOpTag (VecAddOp IntVec 8 W16) = 841-primOpTag (VecAddOp IntVec 4 W32) = 842-primOpTag (VecAddOp IntVec 2 W64) = 843-primOpTag (VecAddOp IntVec 32 W8) = 844-primOpTag (VecAddOp IntVec 16 W16) = 845-primOpTag (VecAddOp IntVec 8 W32) = 846-primOpTag (VecAddOp IntVec 4 W64) = 847-primOpTag (VecAddOp IntVec 64 W8) = 848-primOpTag (VecAddOp IntVec 32 W16) = 849-primOpTag (VecAddOp IntVec 16 W32) = 850-primOpTag (VecAddOp IntVec 8 W64) = 851-primOpTag (VecAddOp WordVec 16 W8) = 852-primOpTag (VecAddOp WordVec 8 W16) = 853-primOpTag (VecAddOp WordVec 4 W32) = 854-primOpTag (VecAddOp WordVec 2 W64) = 855-primOpTag (VecAddOp WordVec 32 W8) = 856-primOpTag (VecAddOp WordVec 16 W16) = 857-primOpTag (VecAddOp WordVec 8 W32) = 858-primOpTag (VecAddOp WordVec 4 W64) = 859-primOpTag (VecAddOp WordVec 64 W8) = 860-primOpTag (VecAddOp WordVec 32 W16) = 861-primOpTag (VecAddOp WordVec 16 W32) = 862-primOpTag (VecAddOp WordVec 8 W64) = 863-primOpTag (VecAddOp FloatVec 4 W32) = 864-primOpTag (VecAddOp FloatVec 2 W64) = 865-primOpTag (VecAddOp FloatVec 8 W32) = 866-primOpTag (VecAddOp FloatVec 4 W64) = 867-primOpTag (VecAddOp FloatVec 16 W32) = 868-primOpTag (VecAddOp FloatVec 8 W64) = 869-primOpTag (VecSubOp IntVec 16 W8) = 870-primOpTag (VecSubOp IntVec 8 W16) = 871-primOpTag (VecSubOp IntVec 4 W32) = 872-primOpTag (VecSubOp IntVec 2 W64) = 873-primOpTag (VecSubOp IntVec 32 W8) = 874-primOpTag (VecSubOp IntVec 16 W16) = 875-primOpTag (VecSubOp IntVec 8 W32) = 876-primOpTag (VecSubOp IntVec 4 W64) = 877-primOpTag (VecSubOp IntVec 64 W8) = 878-primOpTag (VecSubOp IntVec 32 W16) = 879-primOpTag (VecSubOp IntVec 16 W32) = 880-primOpTag (VecSubOp IntVec 8 W64) = 881-primOpTag (VecSubOp WordVec 16 W8) = 882-primOpTag (VecSubOp WordVec 8 W16) = 883-primOpTag (VecSubOp WordVec 4 W32) = 884-primOpTag (VecSubOp WordVec 2 W64) = 885-primOpTag (VecSubOp WordVec 32 W8) = 886-primOpTag (VecSubOp WordVec 16 W16) = 887-primOpTag (VecSubOp WordVec 8 W32) = 888-primOpTag (VecSubOp WordVec 4 W64) = 889-primOpTag (VecSubOp WordVec 64 W8) = 890-primOpTag (VecSubOp WordVec 32 W16) = 891-primOpTag (VecSubOp WordVec 16 W32) = 892-primOpTag (VecSubOp WordVec 8 W64) = 893-primOpTag (VecSubOp FloatVec 4 W32) = 894-primOpTag (VecSubOp FloatVec 2 W64) = 895-primOpTag (VecSubOp FloatVec 8 W32) = 896-primOpTag (VecSubOp FloatVec 4 W64) = 897-primOpTag (VecSubOp FloatVec 16 W32) = 898-primOpTag (VecSubOp FloatVec 8 W64) = 899-primOpTag (VecMulOp IntVec 16 W8) = 900-primOpTag (VecMulOp IntVec 8 W16) = 901-primOpTag (VecMulOp IntVec 4 W32) = 902-primOpTag (VecMulOp IntVec 2 W64) = 903-primOpTag (VecMulOp IntVec 32 W8) = 904-primOpTag (VecMulOp IntVec 16 W16) = 905-primOpTag (VecMulOp IntVec 8 W32) = 906-primOpTag (VecMulOp IntVec 4 W64) = 907-primOpTag (VecMulOp IntVec 64 W8) = 908-primOpTag (VecMulOp IntVec 32 W16) = 909-primOpTag (VecMulOp IntVec 16 W32) = 910-primOpTag (VecMulOp IntVec 8 W64) = 911-primOpTag (VecMulOp WordVec 16 W8) = 912-primOpTag (VecMulOp WordVec 8 W16) = 913-primOpTag (VecMulOp WordVec 4 W32) = 914-primOpTag (VecMulOp WordVec 2 W64) = 915-primOpTag (VecMulOp WordVec 32 W8) = 916-primOpTag (VecMulOp WordVec 16 W16) = 917-primOpTag (VecMulOp WordVec 8 W32) = 918-primOpTag (VecMulOp WordVec 4 W64) = 919-primOpTag (VecMulOp WordVec 64 W8) = 920-primOpTag (VecMulOp WordVec 32 W16) = 921-primOpTag (VecMulOp WordVec 16 W32) = 922-primOpTag (VecMulOp WordVec 8 W64) = 923-primOpTag (VecMulOp FloatVec 4 W32) = 924-primOpTag (VecMulOp FloatVec 2 W64) = 925-primOpTag (VecMulOp FloatVec 8 W32) = 926-primOpTag (VecMulOp FloatVec 4 W64) = 927-primOpTag (VecMulOp FloatVec 16 W32) = 928-primOpTag (VecMulOp FloatVec 8 W64) = 929-primOpTag (VecDivOp FloatVec 4 W32) = 930-primOpTag (VecDivOp FloatVec 2 W64) = 931-primOpTag (VecDivOp FloatVec 8 W32) = 932-primOpTag (VecDivOp FloatVec 4 W64) = 933-primOpTag (VecDivOp FloatVec 16 W32) = 934-primOpTag (VecDivOp FloatVec 8 W64) = 935-primOpTag (VecQuotOp IntVec 16 W8) = 936-primOpTag (VecQuotOp IntVec 8 W16) = 937-primOpTag (VecQuotOp IntVec 4 W32) = 938-primOpTag (VecQuotOp IntVec 2 W64) = 939-primOpTag (VecQuotOp IntVec 32 W8) = 940-primOpTag (VecQuotOp IntVec 16 W16) = 941-primOpTag (VecQuotOp IntVec 8 W32) = 942-primOpTag (VecQuotOp IntVec 4 W64) = 943-primOpTag (VecQuotOp IntVec 64 W8) = 944-primOpTag (VecQuotOp IntVec 32 W16) = 945-primOpTag (VecQuotOp IntVec 16 W32) = 946-primOpTag (VecQuotOp IntVec 8 W64) = 947-primOpTag (VecQuotOp WordVec 16 W8) = 948-primOpTag (VecQuotOp WordVec 8 W16) = 949-primOpTag (VecQuotOp WordVec 4 W32) = 950-primOpTag (VecQuotOp WordVec 2 W64) = 951-primOpTag (VecQuotOp WordVec 32 W8) = 952-primOpTag (VecQuotOp WordVec 16 W16) = 953-primOpTag (VecQuotOp WordVec 8 W32) = 954-primOpTag (VecQuotOp WordVec 4 W64) = 955-primOpTag (VecQuotOp WordVec 64 W8) = 956-primOpTag (VecQuotOp WordVec 32 W16) = 957-primOpTag (VecQuotOp WordVec 16 W32) = 958-primOpTag (VecQuotOp WordVec 8 W64) = 959-primOpTag (VecRemOp IntVec 16 W8) = 960-primOpTag (VecRemOp IntVec 8 W16) = 961-primOpTag (VecRemOp IntVec 4 W32) = 962-primOpTag (VecRemOp IntVec 2 W64) = 963-primOpTag (VecRemOp IntVec 32 W8) = 964-primOpTag (VecRemOp IntVec 16 W16) = 965-primOpTag (VecRemOp IntVec 8 W32) = 966-primOpTag (VecRemOp IntVec 4 W64) = 967-primOpTag (VecRemOp IntVec 64 W8) = 968-primOpTag (VecRemOp IntVec 32 W16) = 969-primOpTag (VecRemOp IntVec 16 W32) = 970-primOpTag (VecRemOp IntVec 8 W64) = 971-primOpTag (VecRemOp WordVec 16 W8) = 972-primOpTag (VecRemOp WordVec 8 W16) = 973-primOpTag (VecRemOp WordVec 4 W32) = 974-primOpTag (VecRemOp WordVec 2 W64) = 975-primOpTag (VecRemOp WordVec 32 W8) = 976-primOpTag (VecRemOp WordVec 16 W16) = 977-primOpTag (VecRemOp WordVec 8 W32) = 978-primOpTag (VecRemOp WordVec 4 W64) = 979-primOpTag (VecRemOp WordVec 64 W8) = 980-primOpTag (VecRemOp WordVec 32 W16) = 981-primOpTag (VecRemOp WordVec 16 W32) = 982-primOpTag (VecRemOp WordVec 8 W64) = 983-primOpTag (VecNegOp IntVec 16 W8) = 984-primOpTag (VecNegOp IntVec 8 W16) = 985-primOpTag (VecNegOp IntVec 4 W32) = 986-primOpTag (VecNegOp IntVec 2 W64) = 987-primOpTag (VecNegOp IntVec 32 W8) = 988-primOpTag (VecNegOp IntVec 16 W16) = 989-primOpTag (VecNegOp IntVec 8 W32) = 990-primOpTag (VecNegOp IntVec 4 W64) = 991-primOpTag (VecNegOp IntVec 64 W8) = 992-primOpTag (VecNegOp IntVec 32 W16) = 993-primOpTag (VecNegOp IntVec 16 W32) = 994-primOpTag (VecNegOp IntVec 8 W64) = 995-primOpTag (VecNegOp FloatVec 4 W32) = 996-primOpTag (VecNegOp FloatVec 2 W64) = 997-primOpTag (VecNegOp FloatVec 8 W32) = 998-primOpTag (VecNegOp FloatVec 4 W64) = 999-primOpTag (VecNegOp FloatVec 16 W32) = 1000-primOpTag (VecNegOp FloatVec 8 W64) = 1001-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 1002-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 1003-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 1004-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 1005-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 1006-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 1007-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 1008-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 1009-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 1010-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 1011-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 1012-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 1013-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 1014-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 1015-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 1016-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 1017-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 1018-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 1019-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 1020-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 1021-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 1022-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 1023-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 1024-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 1025-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 1026-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 1027-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 1028-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 1029-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 1030-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 1031-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 1032-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 1033-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 1034-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 1035-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 1036-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 1037-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 1038-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 1039-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 1040-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 1041-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 1042-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 1043-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 1044-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 1045-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 1046-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 1047-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 1048-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 1049-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 1050-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 1051-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 1052-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 1053-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 1054-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 1055-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 1056-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1057-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1058-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1059-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1060-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1061-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1062-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1063-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1064-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1065-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1066-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1067-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1068-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1069-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1070-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1071-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1072-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1073-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1074-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1075-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1076-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1077-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1078-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1079-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1080-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1081-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1082-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1083-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1084-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1085-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1086-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1087-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1088-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1089-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1090-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1091-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1092-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1093-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1094-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1095-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1096-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1097-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1098-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1099-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1100-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1101-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1102-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1103-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1104-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1105-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1106-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1107-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1108-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1109-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1110-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1111-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1112-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1113-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1114-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1115-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1116-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1117-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1118-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1119-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1120-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1121-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1122-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1123-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1124-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1125-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1126-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1127-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1128-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1129-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1130-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1131-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1132-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1133-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1134-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1135-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1136-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1137-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1138-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1139-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1140-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1141-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1142-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1143-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1144-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1145-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1146-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1147-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1148-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1149-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1150-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1151-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1152-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1153-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1154-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1155-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1156-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1157-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1158-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1159-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1160-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1161-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1162-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1163-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1164-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1165-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1166-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1167-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1168-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1169-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1170-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1171-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1172-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1173-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1174-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1175-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1176-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1177-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1178-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1179-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1180-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1181-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1182-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1183-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1184-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1185-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1186-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1187-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1188-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1189-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1190-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1191-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1192-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1193-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1194-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1195-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1196-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1197-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1198-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1199-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1200-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1201-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1202-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1203-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1204-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1205-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1206-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1207-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1208-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1209-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1210-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1211-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1212-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1213-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1214-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1215-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1216-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1217-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1218-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1219-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1220-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1221-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1222-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1223-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1224-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1225-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1226-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1227-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1228-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1229-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1230-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1231-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1232-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1233-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1234-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1235-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1236-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1237-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1238-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1239-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1240-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1241-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1242-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1243-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1244-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1245-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1246-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1247-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1248-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1249-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1250-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1251-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1252-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1253-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1254-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1255-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1256-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1257-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1258-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1259-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1260-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1261-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1262-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1263-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1264-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1265-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1266-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1267-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1268-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1269-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1270-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1271-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1272-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1273-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1274-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1275-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1276-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1277-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1278-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1279-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1280-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1281-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1282-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1283-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1284-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1285-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1286-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1287-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1288-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1289-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1290-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1291-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1292-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1293-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1294-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1295-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1296-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1297-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1298-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1299-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1300-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1301-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1302-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1303-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1304-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1305-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1306-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1307-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1308-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1309-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1310-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1311-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1312-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1313-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1314-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1315-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1316-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1317-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1318-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1319-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1320-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1321-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1322-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1323-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1324-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1325-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1326-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1327-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1328-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1329-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1330-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1331-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1332-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1333-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1334-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1335-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1336-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1337-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1338-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1339-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1340-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1341-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1342-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1343-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1344-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1345-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1346-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1347-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1348-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1349-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1350-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1351-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1352-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1353-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1354-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1355-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1356-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1357-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1358-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1359-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1360-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1361-primOpTag (VecFMAdd FloatVec 4 W32) = 1362-primOpTag (VecFMAdd FloatVec 2 W64) = 1363-primOpTag (VecFMAdd FloatVec 8 W32) = 1364-primOpTag (VecFMAdd FloatVec 4 W64) = 1365-primOpTag (VecFMAdd FloatVec 16 W32) = 1366-primOpTag (VecFMAdd FloatVec 8 W64) = 1367-primOpTag (VecFMSub FloatVec 4 W32) = 1368-primOpTag (VecFMSub FloatVec 2 W64) = 1369-primOpTag (VecFMSub FloatVec 8 W32) = 1370-primOpTag (VecFMSub FloatVec 4 W64) = 1371-primOpTag (VecFMSub FloatVec 16 W32) = 1372-primOpTag (VecFMSub FloatVec 8 W64) = 1373-primOpTag (VecFNMAdd FloatVec 4 W32) = 1374-primOpTag (VecFNMAdd FloatVec 2 W64) = 1375-primOpTag (VecFNMAdd FloatVec 8 W32) = 1376-primOpTag (VecFNMAdd FloatVec 4 W64) = 1377-primOpTag (VecFNMAdd FloatVec 16 W32) = 1378-primOpTag (VecFNMAdd FloatVec 8 W64) = 1379-primOpTag (VecFNMSub FloatVec 4 W32) = 1380-primOpTag (VecFNMSub FloatVec 2 W64) = 1381-primOpTag (VecFNMSub FloatVec 8 W32) = 1382-primOpTag (VecFNMSub FloatVec 4 W64) = 1383-primOpTag (VecFNMSub FloatVec 16 W32) = 1384-primOpTag (VecFNMSub FloatVec 8 W64) = 1385-primOpTag (VecShuffleOp IntVec 16 W8) = 1386-primOpTag (VecShuffleOp IntVec 8 W16) = 1387-primOpTag (VecShuffleOp IntVec 4 W32) = 1388-primOpTag (VecShuffleOp IntVec 2 W64) = 1389-primOpTag (VecShuffleOp IntVec 32 W8) = 1390-primOpTag (VecShuffleOp IntVec 16 W16) = 1391-primOpTag (VecShuffleOp IntVec 8 W32) = 1392-primOpTag (VecShuffleOp IntVec 4 W64) = 1393-primOpTag (VecShuffleOp IntVec 64 W8) = 1394-primOpTag (VecShuffleOp IntVec 32 W16) = 1395-primOpTag (VecShuffleOp IntVec 16 W32) = 1396-primOpTag (VecShuffleOp IntVec 8 W64) = 1397-primOpTag (VecShuffleOp WordVec 16 W8) = 1398-primOpTag (VecShuffleOp WordVec 8 W16) = 1399-primOpTag (VecShuffleOp WordVec 4 W32) = 1400-primOpTag (VecShuffleOp WordVec 2 W64) = 1401-primOpTag (VecShuffleOp WordVec 32 W8) = 1402-primOpTag (VecShuffleOp WordVec 16 W16) = 1403-primOpTag (VecShuffleOp WordVec 8 W32) = 1404-primOpTag (VecShuffleOp WordVec 4 W64) = 1405-primOpTag (VecShuffleOp WordVec 64 W8) = 1406-primOpTag (VecShuffleOp WordVec 32 W16) = 1407-primOpTag (VecShuffleOp WordVec 16 W32) = 1408-primOpTag (VecShuffleOp WordVec 8 W64) = 1409-primOpTag (VecShuffleOp FloatVec 4 W32) = 1410-primOpTag (VecShuffleOp FloatVec 2 W64) = 1411-primOpTag (VecShuffleOp FloatVec 8 W32) = 1412-primOpTag (VecShuffleOp FloatVec 4 W64) = 1413-primOpTag (VecShuffleOp FloatVec 16 W32) = 1414-primOpTag (VecShuffleOp FloatVec 8 W64) = 1415-primOpTag (VecMinOp IntVec 16 W8) = 1416-primOpTag (VecMinOp IntVec 8 W16) = 1417-primOpTag (VecMinOp IntVec 4 W32) = 1418-primOpTag (VecMinOp IntVec 2 W64) = 1419-primOpTag (VecMinOp IntVec 32 W8) = 1420-primOpTag (VecMinOp IntVec 16 W16) = 1421-primOpTag (VecMinOp IntVec 8 W32) = 1422-primOpTag (VecMinOp IntVec 4 W64) = 1423-primOpTag (VecMinOp IntVec 64 W8) = 1424-primOpTag (VecMinOp IntVec 32 W16) = 1425-primOpTag (VecMinOp IntVec 16 W32) = 1426-primOpTag (VecMinOp IntVec 8 W64) = 1427-primOpTag (VecMinOp WordVec 16 W8) = 1428-primOpTag (VecMinOp WordVec 8 W16) = 1429-primOpTag (VecMinOp WordVec 4 W32) = 1430-primOpTag (VecMinOp WordVec 2 W64) = 1431-primOpTag (VecMinOp WordVec 32 W8) = 1432-primOpTag (VecMinOp WordVec 16 W16) = 1433-primOpTag (VecMinOp WordVec 8 W32) = 1434-primOpTag (VecMinOp WordVec 4 W64) = 1435-primOpTag (VecMinOp WordVec 64 W8) = 1436-primOpTag (VecMinOp WordVec 32 W16) = 1437-primOpTag (VecMinOp WordVec 16 W32) = 1438-primOpTag (VecMinOp WordVec 8 W64) = 1439-primOpTag (VecMinOp FloatVec 4 W32) = 1440-primOpTag (VecMinOp FloatVec 2 W64) = 1441-primOpTag (VecMinOp FloatVec 8 W32) = 1442-primOpTag (VecMinOp FloatVec 4 W64) = 1443-primOpTag (VecMinOp FloatVec 16 W32) = 1444-primOpTag (VecMinOp FloatVec 8 W64) = 1445-primOpTag (VecMaxOp IntVec 16 W8) = 1446-primOpTag (VecMaxOp IntVec 8 W16) = 1447-primOpTag (VecMaxOp IntVec 4 W32) = 1448-primOpTag (VecMaxOp IntVec 2 W64) = 1449-primOpTag (VecMaxOp IntVec 32 W8) = 1450-primOpTag (VecMaxOp IntVec 16 W16) = 1451-primOpTag (VecMaxOp IntVec 8 W32) = 1452-primOpTag (VecMaxOp IntVec 4 W64) = 1453-primOpTag (VecMaxOp IntVec 64 W8) = 1454-primOpTag (VecMaxOp IntVec 32 W16) = 1455-primOpTag (VecMaxOp IntVec 16 W32) = 1456-primOpTag (VecMaxOp IntVec 8 W64) = 1457-primOpTag (VecMaxOp WordVec 16 W8) = 1458-primOpTag (VecMaxOp WordVec 8 W16) = 1459-primOpTag (VecMaxOp WordVec 4 W32) = 1460-primOpTag (VecMaxOp WordVec 2 W64) = 1461-primOpTag (VecMaxOp WordVec 32 W8) = 1462-primOpTag (VecMaxOp WordVec 16 W16) = 1463-primOpTag (VecMaxOp WordVec 8 W32) = 1464-primOpTag (VecMaxOp WordVec 4 W64) = 1465-primOpTag (VecMaxOp WordVec 64 W8) = 1466-primOpTag (VecMaxOp WordVec 32 W16) = 1467-primOpTag (VecMaxOp WordVec 16 W32) = 1468-primOpTag (VecMaxOp WordVec 8 W64) = 1469-primOpTag (VecMaxOp FloatVec 4 W32) = 1470-primOpTag (VecMaxOp FloatVec 2 W64) = 1471-primOpTag (VecMaxOp FloatVec 8 W32) = 1472-primOpTag (VecMaxOp FloatVec 4 W64) = 1473-primOpTag (VecMaxOp FloatVec 16 W32) = 1474-primOpTag (VecMaxOp FloatVec 8 W64) = 1475-primOpTag PrefetchByteArrayOp3 = 1476-primOpTag PrefetchMutableByteArrayOp3 = 1477-primOpTag PrefetchAddrOp3 = 1478-primOpTag PrefetchValueOp3 = 1479-primOpTag PrefetchByteArrayOp2 = 1480-primOpTag PrefetchMutableByteArrayOp2 = 1481-primOpTag PrefetchAddrOp2 = 1482-primOpTag PrefetchValueOp2 = 1483-primOpTag PrefetchByteArrayOp1 = 1484-primOpTag PrefetchMutableByteArrayOp1 = 1485-primOpTag PrefetchAddrOp1 = 1486-primOpTag PrefetchValueOp1 = 1487-primOpTag PrefetchByteArrayOp0 = 1488-primOpTag PrefetchMutableByteArrayOp0 = 1489-primOpTag PrefetchAddrOp0 = 1490-primOpTag PrefetchValueOp0 = 1491+maxPrimOpTag = 1490+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 0+primOpTag CharGeOp = 1+primOpTag CharEqOp = 2+primOpTag CharNeOp = 3+primOpTag CharLtOp = 4+primOpTag CharLeOp = 5+primOpTag OrdOp = 6+primOpTag Int8ToIntOp = 7+primOpTag IntToInt8Op = 8+primOpTag Int8NegOp = 9+primOpTag Int8AddOp = 10+primOpTag Int8SubOp = 11+primOpTag Int8MulOp = 12+primOpTag Int8QuotOp = 13+primOpTag Int8RemOp = 14+primOpTag Int8QuotRemOp = 15+primOpTag Int8SllOp = 16+primOpTag Int8SraOp = 17+primOpTag Int8SrlOp = 18+primOpTag Int8ToWord8Op = 19+primOpTag Int8EqOp = 20+primOpTag Int8GeOp = 21+primOpTag Int8GtOp = 22+primOpTag Int8LeOp = 23+primOpTag Int8LtOp = 24+primOpTag Int8NeOp = 25+primOpTag Word8ToWordOp = 26+primOpTag WordToWord8Op = 27+primOpTag Word8AddOp = 28+primOpTag Word8SubOp = 29+primOpTag Word8MulOp = 30+primOpTag Word8QuotOp = 31+primOpTag Word8RemOp = 32+primOpTag Word8QuotRemOp = 33+primOpTag Word8AndOp = 34+primOpTag Word8OrOp = 35+primOpTag Word8XorOp = 36+primOpTag Word8NotOp = 37+primOpTag Word8SllOp = 38+primOpTag Word8SrlOp = 39+primOpTag Word8ToInt8Op = 40+primOpTag Word8EqOp = 41+primOpTag Word8GeOp = 42+primOpTag Word8GtOp = 43+primOpTag Word8LeOp = 44+primOpTag Word8LtOp = 45+primOpTag Word8NeOp = 46+primOpTag Int16ToIntOp = 47+primOpTag IntToInt16Op = 48+primOpTag Int16NegOp = 49+primOpTag Int16AddOp = 50+primOpTag Int16SubOp = 51+primOpTag Int16MulOp = 52+primOpTag Int16QuotOp = 53+primOpTag Int16RemOp = 54+primOpTag Int16QuotRemOp = 55+primOpTag Int16SllOp = 56+primOpTag Int16SraOp = 57+primOpTag Int16SrlOp = 58+primOpTag Int16ToWord16Op = 59+primOpTag Int16EqOp = 60+primOpTag Int16GeOp = 61+primOpTag Int16GtOp = 62+primOpTag Int16LeOp = 63+primOpTag Int16LtOp = 64+primOpTag Int16NeOp = 65+primOpTag Word16ToWordOp = 66+primOpTag WordToWord16Op = 67+primOpTag Word16AddOp = 68+primOpTag Word16SubOp = 69+primOpTag Word16MulOp = 70+primOpTag Word16QuotOp = 71+primOpTag Word16RemOp = 72+primOpTag Word16QuotRemOp = 73+primOpTag Word16AndOp = 74+primOpTag Word16OrOp = 75+primOpTag Word16XorOp = 76+primOpTag Word16NotOp = 77+primOpTag Word16SllOp = 78+primOpTag Word16SrlOp = 79+primOpTag Word16ToInt16Op = 80+primOpTag Word16EqOp = 81+primOpTag Word16GeOp = 82+primOpTag Word16GtOp = 83+primOpTag Word16LeOp = 84+primOpTag Word16LtOp = 85+primOpTag Word16NeOp = 86+primOpTag Int32ToIntOp = 87+primOpTag IntToInt32Op = 88+primOpTag Int32NegOp = 89+primOpTag Int32AddOp = 90+primOpTag Int32SubOp = 91+primOpTag Int32MulOp = 92+primOpTag Int32QuotOp = 93+primOpTag Int32RemOp = 94+primOpTag Int32QuotRemOp = 95+primOpTag Int32SllOp = 96+primOpTag Int32SraOp = 97+primOpTag Int32SrlOp = 98+primOpTag Int32ToWord32Op = 99+primOpTag Int32EqOp = 100+primOpTag Int32GeOp = 101+primOpTag Int32GtOp = 102+primOpTag Int32LeOp = 103+primOpTag Int32LtOp = 104+primOpTag Int32NeOp = 105+primOpTag Word32ToWordOp = 106+primOpTag WordToWord32Op = 107+primOpTag Word32AddOp = 108+primOpTag Word32SubOp = 109+primOpTag Word32MulOp = 110+primOpTag Word32QuotOp = 111+primOpTag Word32RemOp = 112+primOpTag Word32QuotRemOp = 113+primOpTag Word32AndOp = 114+primOpTag Word32OrOp = 115+primOpTag Word32XorOp = 116+primOpTag Word32NotOp = 117+primOpTag Word32SllOp = 118+primOpTag Word32SrlOp = 119+primOpTag Word32ToInt32Op = 120+primOpTag Word32EqOp = 121+primOpTag Word32GeOp = 122+primOpTag Word32GtOp = 123+primOpTag Word32LeOp = 124+primOpTag Word32LtOp = 125+primOpTag Word32NeOp = 126+primOpTag Int64ToIntOp = 127+primOpTag IntToInt64Op = 128+primOpTag Int64NegOp = 129+primOpTag Int64AddOp = 130+primOpTag Int64SubOp = 131+primOpTag Int64MulOp = 132+primOpTag Int64QuotOp = 133+primOpTag Int64RemOp = 134+primOpTag Int64SllOp = 135+primOpTag Int64SraOp = 136+primOpTag Int64SrlOp = 137+primOpTag Int64ToWord64Op = 138+primOpTag Int64EqOp = 139+primOpTag Int64GeOp = 140+primOpTag Int64GtOp = 141+primOpTag Int64LeOp = 142+primOpTag Int64LtOp = 143+primOpTag Int64NeOp = 144+primOpTag Word64ToWordOp = 145+primOpTag WordToWord64Op = 146+primOpTag Word64AddOp = 147+primOpTag Word64SubOp = 148+primOpTag Word64MulOp = 149+primOpTag Word64QuotOp = 150+primOpTag Word64RemOp = 151+primOpTag Word64AndOp = 152+primOpTag Word64OrOp = 153+primOpTag Word64XorOp = 154+primOpTag Word64NotOp = 155+primOpTag Word64SllOp = 156+primOpTag Word64SrlOp = 157+primOpTag Word64ToInt64Op = 158+primOpTag Word64EqOp = 159+primOpTag Word64GeOp = 160+primOpTag Word64GtOp = 161+primOpTag Word64LeOp = 162+primOpTag Word64LtOp = 163+primOpTag Word64NeOp = 164+primOpTag IntAddOp = 165+primOpTag IntSubOp = 166+primOpTag IntMulOp = 167+primOpTag IntMul2Op = 168+primOpTag IntMulMayOfloOp = 169+primOpTag IntQuotOp = 170+primOpTag IntRemOp = 171+primOpTag IntQuotRemOp = 172+primOpTag IntAndOp = 173+primOpTag IntOrOp = 174+primOpTag IntXorOp = 175+primOpTag IntNotOp = 176+primOpTag IntNegOp = 177+primOpTag IntAddCOp = 178+primOpTag IntSubCOp = 179+primOpTag IntGtOp = 180+primOpTag IntGeOp = 181+primOpTag IntEqOp = 182+primOpTag IntNeOp = 183+primOpTag IntLtOp = 184+primOpTag IntLeOp = 185+primOpTag ChrOp = 186+primOpTag IntToWordOp = 187+primOpTag IntToFloatOp = 188+primOpTag IntToDoubleOp = 189+primOpTag WordToFloatOp = 190+primOpTag WordToDoubleOp = 191+primOpTag IntSllOp = 192+primOpTag IntSraOp = 193+primOpTag IntSrlOp = 194+primOpTag WordAddOp = 195+primOpTag WordAddCOp = 196+primOpTag WordSubCOp = 197+primOpTag WordAdd2Op = 198+primOpTag WordSubOp = 199+primOpTag WordMulOp = 200+primOpTag WordMul2Op = 201+primOpTag WordQuotOp = 202+primOpTag WordRemOp = 203+primOpTag WordQuotRemOp = 204+primOpTag WordQuotRem2Op = 205+primOpTag WordAndOp = 206+primOpTag WordOrOp = 207+primOpTag WordXorOp = 208+primOpTag WordNotOp = 209+primOpTag WordSllOp = 210+primOpTag WordSrlOp = 211+primOpTag WordToIntOp = 212+primOpTag WordGtOp = 213+primOpTag WordGeOp = 214+primOpTag WordEqOp = 215+primOpTag WordNeOp = 216+primOpTag WordLtOp = 217+primOpTag WordLeOp = 218+primOpTag PopCnt8Op = 219+primOpTag PopCnt16Op = 220+primOpTag PopCnt32Op = 221+primOpTag PopCnt64Op = 222+primOpTag PopCntOp = 223+primOpTag Pdep8Op = 224+primOpTag Pdep16Op = 225+primOpTag Pdep32Op = 226+primOpTag Pdep64Op = 227+primOpTag PdepOp = 228+primOpTag Pext8Op = 229+primOpTag Pext16Op = 230+primOpTag Pext32Op = 231+primOpTag Pext64Op = 232+primOpTag PextOp = 233+primOpTag Clz8Op = 234+primOpTag Clz16Op = 235+primOpTag Clz32Op = 236+primOpTag Clz64Op = 237+primOpTag ClzOp = 238+primOpTag Ctz8Op = 239+primOpTag Ctz16Op = 240+primOpTag Ctz32Op = 241+primOpTag Ctz64Op = 242+primOpTag CtzOp = 243+primOpTag BSwap16Op = 244+primOpTag BSwap32Op = 245+primOpTag BSwap64Op = 246+primOpTag BSwapOp = 247+primOpTag BRev8Op = 248+primOpTag BRev16Op = 249+primOpTag BRev32Op = 250+primOpTag BRev64Op = 251+primOpTag BRevOp = 252+primOpTag Narrow8IntOp = 253+primOpTag Narrow16IntOp = 254+primOpTag Narrow32IntOp = 255+primOpTag Narrow8WordOp = 256+primOpTag Narrow16WordOp = 257+primOpTag Narrow32WordOp = 258+primOpTag DoubleGtOp = 259+primOpTag DoubleGeOp = 260+primOpTag DoubleEqOp = 261+primOpTag DoubleNeOp = 262+primOpTag DoubleLtOp = 263+primOpTag DoubleLeOp = 264+primOpTag DoubleMinOp = 265+primOpTag DoubleMaxOp = 266+primOpTag DoubleAddOp = 267+primOpTag DoubleSubOp = 268+primOpTag DoubleMulOp = 269+primOpTag DoubleDivOp = 270+primOpTag DoubleNegOp = 271+primOpTag DoubleFabsOp = 272+primOpTag DoubleToIntOp = 273+primOpTag DoubleToFloatOp = 274+primOpTag DoubleExpOp = 275+primOpTag DoubleExpM1Op = 276+primOpTag DoubleLogOp = 277+primOpTag DoubleLog1POp = 278+primOpTag DoubleSqrtOp = 279+primOpTag DoubleSinOp = 280+primOpTag DoubleCosOp = 281+primOpTag DoubleTanOp = 282+primOpTag DoubleAsinOp = 283+primOpTag DoubleAcosOp = 284+primOpTag DoubleAtanOp = 285+primOpTag DoubleSinhOp = 286+primOpTag DoubleCoshOp = 287+primOpTag DoubleTanhOp = 288+primOpTag DoubleAsinhOp = 289+primOpTag DoubleAcoshOp = 290+primOpTag DoubleAtanhOp = 291+primOpTag DoublePowerOp = 292+primOpTag DoubleDecode_2IntOp = 293+primOpTag DoubleDecode_Int64Op = 294+primOpTag CastDoubleToWord64Op = 295+primOpTag CastWord64ToDoubleOp = 296+primOpTag FloatGtOp = 297+primOpTag FloatGeOp = 298+primOpTag FloatEqOp = 299+primOpTag FloatNeOp = 300+primOpTag FloatLtOp = 301+primOpTag FloatLeOp = 302+primOpTag FloatMinOp = 303+primOpTag FloatMaxOp = 304+primOpTag FloatAddOp = 305+primOpTag FloatSubOp = 306+primOpTag FloatMulOp = 307+primOpTag FloatDivOp = 308+primOpTag FloatNegOp = 309+primOpTag FloatFabsOp = 310+primOpTag FloatToIntOp = 311+primOpTag FloatExpOp = 312+primOpTag FloatExpM1Op = 313+primOpTag FloatLogOp = 314+primOpTag FloatLog1POp = 315+primOpTag FloatSqrtOp = 316+primOpTag FloatSinOp = 317+primOpTag FloatCosOp = 318+primOpTag FloatTanOp = 319+primOpTag FloatAsinOp = 320+primOpTag FloatAcosOp = 321+primOpTag FloatAtanOp = 322+primOpTag FloatSinhOp = 323+primOpTag FloatCoshOp = 324+primOpTag FloatTanhOp = 325+primOpTag FloatAsinhOp = 326+primOpTag FloatAcoshOp = 327+primOpTag FloatAtanhOp = 328+primOpTag FloatPowerOp = 329+primOpTag FloatToDoubleOp = 330+primOpTag FloatDecode_IntOp = 331+primOpTag CastFloatToWord32Op = 332+primOpTag CastWord32ToFloatOp = 333+primOpTag FloatFMAdd = 334+primOpTag FloatFMSub = 335+primOpTag FloatFNMAdd = 336+primOpTag FloatFNMSub = 337+primOpTag DoubleFMAdd = 338+primOpTag DoubleFMSub = 339+primOpTag DoubleFNMAdd = 340+primOpTag DoubleFNMSub = 341+primOpTag NewArrayOp = 342+primOpTag ReadArrayOp = 343+primOpTag WriteArrayOp = 344+primOpTag SizeofArrayOp = 345+primOpTag SizeofMutableArrayOp = 346+primOpTag IndexArrayOp = 347+primOpTag UnsafeFreezeArrayOp = 348+primOpTag UnsafeThawArrayOp = 349+primOpTag CopyArrayOp = 350+primOpTag CopyMutableArrayOp = 351+primOpTag CloneArrayOp = 352+primOpTag CloneMutableArrayOp = 353+primOpTag FreezeArrayOp = 354+primOpTag ThawArrayOp = 355+primOpTag CasArrayOp = 356+primOpTag NewSmallArrayOp = 357+primOpTag ShrinkSmallMutableArrayOp_Char = 358+primOpTag ReadSmallArrayOp = 359+primOpTag WriteSmallArrayOp = 360+primOpTag SizeofSmallArrayOp = 361+primOpTag SizeofSmallMutableArrayOp = 362+primOpTag GetSizeofSmallMutableArrayOp = 363+primOpTag IndexSmallArrayOp = 364+primOpTag UnsafeFreezeSmallArrayOp = 365+primOpTag UnsafeThawSmallArrayOp = 366+primOpTag CopySmallArrayOp = 367+primOpTag CopySmallMutableArrayOp = 368+primOpTag CloneSmallArrayOp = 369+primOpTag CloneSmallMutableArrayOp = 370+primOpTag FreezeSmallArrayOp = 371+primOpTag ThawSmallArrayOp = 372+primOpTag CasSmallArrayOp = 373+primOpTag NewByteArrayOp_Char = 374+primOpTag NewPinnedByteArrayOp_Char = 375+primOpTag NewAlignedPinnedByteArrayOp_Char = 376+primOpTag MutableByteArrayIsPinnedOp = 377+primOpTag ByteArrayIsPinnedOp = 378+primOpTag ByteArrayIsWeaklyPinnedOp = 379+primOpTag MutableByteArrayIsWeaklyPinnedOp = 380+primOpTag ByteArrayContents_Char = 381+primOpTag MutableByteArrayContents_Char = 382+primOpTag ShrinkMutableByteArrayOp_Char = 383+primOpTag ResizeMutableByteArrayOp_Char = 384+primOpTag UnsafeFreezeByteArrayOp = 385+primOpTag UnsafeThawByteArrayOp = 386+primOpTag SizeofByteArrayOp = 387+primOpTag SizeofMutableByteArrayOp = 388+primOpTag GetSizeofMutableByteArrayOp = 389+primOpTag IndexByteArrayOp_Char = 390+primOpTag IndexByteArrayOp_WideChar = 391+primOpTag IndexByteArrayOp_Int = 392+primOpTag IndexByteArrayOp_Word = 393+primOpTag IndexByteArrayOp_Addr = 394+primOpTag IndexByteArrayOp_Float = 395+primOpTag IndexByteArrayOp_Double = 396+primOpTag IndexByteArrayOp_StablePtr = 397+primOpTag IndexByteArrayOp_Int8 = 398+primOpTag IndexByteArrayOp_Word8 = 399+primOpTag IndexByteArrayOp_Int16 = 400+primOpTag IndexByteArrayOp_Word16 = 401+primOpTag IndexByteArrayOp_Int32 = 402+primOpTag IndexByteArrayOp_Word32 = 403+primOpTag IndexByteArrayOp_Int64 = 404+primOpTag IndexByteArrayOp_Word64 = 405+primOpTag IndexByteArrayOp_Word8AsChar = 406+primOpTag IndexByteArrayOp_Word8AsWideChar = 407+primOpTag IndexByteArrayOp_Word8AsInt = 408+primOpTag IndexByteArrayOp_Word8AsWord = 409+primOpTag IndexByteArrayOp_Word8AsAddr = 410+primOpTag IndexByteArrayOp_Word8AsFloat = 411+primOpTag IndexByteArrayOp_Word8AsDouble = 412+primOpTag IndexByteArrayOp_Word8AsStablePtr = 413+primOpTag IndexByteArrayOp_Word8AsInt16 = 414+primOpTag IndexByteArrayOp_Word8AsWord16 = 415+primOpTag IndexByteArrayOp_Word8AsInt32 = 416+primOpTag IndexByteArrayOp_Word8AsWord32 = 417+primOpTag IndexByteArrayOp_Word8AsInt64 = 418+primOpTag IndexByteArrayOp_Word8AsWord64 = 419+primOpTag ReadByteArrayOp_Char = 420+primOpTag ReadByteArrayOp_WideChar = 421+primOpTag ReadByteArrayOp_Int = 422+primOpTag ReadByteArrayOp_Word = 423+primOpTag ReadByteArrayOp_Addr = 424+primOpTag ReadByteArrayOp_Float = 425+primOpTag ReadByteArrayOp_Double = 426+primOpTag ReadByteArrayOp_StablePtr = 427+primOpTag ReadByteArrayOp_Int8 = 428+primOpTag ReadByteArrayOp_Word8 = 429+primOpTag ReadByteArrayOp_Int16 = 430+primOpTag ReadByteArrayOp_Word16 = 431+primOpTag ReadByteArrayOp_Int32 = 432+primOpTag ReadByteArrayOp_Word32 = 433+primOpTag ReadByteArrayOp_Int64 = 434+primOpTag ReadByteArrayOp_Word64 = 435+primOpTag ReadByteArrayOp_Word8AsChar = 436+primOpTag ReadByteArrayOp_Word8AsWideChar = 437+primOpTag ReadByteArrayOp_Word8AsInt = 438+primOpTag ReadByteArrayOp_Word8AsWord = 439+primOpTag ReadByteArrayOp_Word8AsAddr = 440+primOpTag ReadByteArrayOp_Word8AsFloat = 441+primOpTag ReadByteArrayOp_Word8AsDouble = 442+primOpTag ReadByteArrayOp_Word8AsStablePtr = 443+primOpTag ReadByteArrayOp_Word8AsInt16 = 444+primOpTag ReadByteArrayOp_Word8AsWord16 = 445+primOpTag ReadByteArrayOp_Word8AsInt32 = 446+primOpTag ReadByteArrayOp_Word8AsWord32 = 447+primOpTag ReadByteArrayOp_Word8AsInt64 = 448+primOpTag ReadByteArrayOp_Word8AsWord64 = 449+primOpTag WriteByteArrayOp_Char = 450+primOpTag WriteByteArrayOp_WideChar = 451+primOpTag WriteByteArrayOp_Int = 452+primOpTag WriteByteArrayOp_Word = 453+primOpTag WriteByteArrayOp_Addr = 454+primOpTag WriteByteArrayOp_Float = 455+primOpTag WriteByteArrayOp_Double = 456+primOpTag WriteByteArrayOp_StablePtr = 457+primOpTag WriteByteArrayOp_Int8 = 458+primOpTag WriteByteArrayOp_Word8 = 459+primOpTag WriteByteArrayOp_Int16 = 460+primOpTag WriteByteArrayOp_Word16 = 461+primOpTag WriteByteArrayOp_Int32 = 462+primOpTag WriteByteArrayOp_Word32 = 463+primOpTag WriteByteArrayOp_Int64 = 464+primOpTag WriteByteArrayOp_Word64 = 465+primOpTag WriteByteArrayOp_Word8AsChar = 466+primOpTag WriteByteArrayOp_Word8AsWideChar = 467+primOpTag WriteByteArrayOp_Word8AsInt = 468+primOpTag WriteByteArrayOp_Word8AsWord = 469+primOpTag WriteByteArrayOp_Word8AsAddr = 470+primOpTag WriteByteArrayOp_Word8AsFloat = 471+primOpTag WriteByteArrayOp_Word8AsDouble = 472+primOpTag WriteByteArrayOp_Word8AsStablePtr = 473+primOpTag WriteByteArrayOp_Word8AsInt16 = 474+primOpTag WriteByteArrayOp_Word8AsWord16 = 475+primOpTag WriteByteArrayOp_Word8AsInt32 = 476+primOpTag WriteByteArrayOp_Word8AsWord32 = 477+primOpTag WriteByteArrayOp_Word8AsInt64 = 478+primOpTag WriteByteArrayOp_Word8AsWord64 = 479+primOpTag CompareByteArraysOp = 480+primOpTag CopyByteArrayOp = 481+primOpTag CopyMutableByteArrayOp = 482+primOpTag CopyMutableByteArrayNonOverlappingOp = 483+primOpTag CopyByteArrayToAddrOp = 484+primOpTag CopyMutableByteArrayToAddrOp = 485+primOpTag CopyAddrToByteArrayOp = 486+primOpTag CopyAddrToAddrOp = 487+primOpTag CopyAddrToAddrNonOverlappingOp = 488+primOpTag SetByteArrayOp = 489+primOpTag SetAddrRangeOp = 490+primOpTag AtomicReadByteArrayOp_Int = 491+primOpTag AtomicWriteByteArrayOp_Int = 492+primOpTag CasByteArrayOp_Int = 493+primOpTag CasByteArrayOp_Int8 = 494+primOpTag CasByteArrayOp_Int16 = 495+primOpTag CasByteArrayOp_Int32 = 496+primOpTag CasByteArrayOp_Int64 = 497+primOpTag FetchAddByteArrayOp_Int = 498+primOpTag FetchSubByteArrayOp_Int = 499+primOpTag FetchAndByteArrayOp_Int = 500+primOpTag FetchNandByteArrayOp_Int = 501+primOpTag FetchOrByteArrayOp_Int = 502+primOpTag FetchXorByteArrayOp_Int = 503+primOpTag AddrAddOp = 504+primOpTag AddrSubOp = 505+primOpTag AddrRemOp = 506+primOpTag AddrToIntOp = 507+primOpTag IntToAddrOp = 508+primOpTag AddrGtOp = 509+primOpTag AddrGeOp = 510+primOpTag AddrEqOp = 511+primOpTag AddrNeOp = 512+primOpTag AddrLtOp = 513+primOpTag AddrLeOp = 514+primOpTag IndexOffAddrOp_Char = 515+primOpTag IndexOffAddrOp_WideChar = 516+primOpTag IndexOffAddrOp_Int = 517+primOpTag IndexOffAddrOp_Word = 518+primOpTag IndexOffAddrOp_Addr = 519+primOpTag IndexOffAddrOp_Float = 520+primOpTag IndexOffAddrOp_Double = 521+primOpTag IndexOffAddrOp_StablePtr = 522+primOpTag IndexOffAddrOp_Int8 = 523+primOpTag IndexOffAddrOp_Word8 = 524+primOpTag IndexOffAddrOp_Int16 = 525+primOpTag IndexOffAddrOp_Word16 = 526+primOpTag IndexOffAddrOp_Int32 = 527+primOpTag IndexOffAddrOp_Word32 = 528+primOpTag IndexOffAddrOp_Int64 = 529+primOpTag IndexOffAddrOp_Word64 = 530+primOpTag IndexOffAddrOp_Word8AsChar = 531+primOpTag IndexOffAddrOp_Word8AsWideChar = 532+primOpTag IndexOffAddrOp_Word8AsInt = 533+primOpTag IndexOffAddrOp_Word8AsWord = 534+primOpTag IndexOffAddrOp_Word8AsAddr = 535+primOpTag IndexOffAddrOp_Word8AsFloat = 536+primOpTag IndexOffAddrOp_Word8AsDouble = 537+primOpTag IndexOffAddrOp_Word8AsStablePtr = 538+primOpTag IndexOffAddrOp_Word8AsInt16 = 539+primOpTag IndexOffAddrOp_Word8AsWord16 = 540+primOpTag IndexOffAddrOp_Word8AsInt32 = 541+primOpTag IndexOffAddrOp_Word8AsWord32 = 542+primOpTag IndexOffAddrOp_Word8AsInt64 = 543+primOpTag IndexOffAddrOp_Word8AsWord64 = 544+primOpTag ReadOffAddrOp_Char = 545+primOpTag ReadOffAddrOp_WideChar = 546+primOpTag ReadOffAddrOp_Int = 547+primOpTag ReadOffAddrOp_Word = 548+primOpTag ReadOffAddrOp_Addr = 549+primOpTag ReadOffAddrOp_Float = 550+primOpTag ReadOffAddrOp_Double = 551+primOpTag ReadOffAddrOp_StablePtr = 552+primOpTag ReadOffAddrOp_Int8 = 553+primOpTag ReadOffAddrOp_Word8 = 554+primOpTag ReadOffAddrOp_Int16 = 555+primOpTag ReadOffAddrOp_Word16 = 556+primOpTag ReadOffAddrOp_Int32 = 557+primOpTag ReadOffAddrOp_Word32 = 558+primOpTag ReadOffAddrOp_Int64 = 559+primOpTag ReadOffAddrOp_Word64 = 560+primOpTag ReadOffAddrOp_Word8AsChar = 561+primOpTag ReadOffAddrOp_Word8AsWideChar = 562+primOpTag ReadOffAddrOp_Word8AsInt = 563+primOpTag ReadOffAddrOp_Word8AsWord = 564+primOpTag ReadOffAddrOp_Word8AsAddr = 565+primOpTag ReadOffAddrOp_Word8AsFloat = 566+primOpTag ReadOffAddrOp_Word8AsDouble = 567+primOpTag ReadOffAddrOp_Word8AsStablePtr = 568+primOpTag ReadOffAddrOp_Word8AsInt16 = 569+primOpTag ReadOffAddrOp_Word8AsWord16 = 570+primOpTag ReadOffAddrOp_Word8AsInt32 = 571+primOpTag ReadOffAddrOp_Word8AsWord32 = 572+primOpTag ReadOffAddrOp_Word8AsInt64 = 573+primOpTag ReadOffAddrOp_Word8AsWord64 = 574+primOpTag WriteOffAddrOp_Char = 575+primOpTag WriteOffAddrOp_WideChar = 576+primOpTag WriteOffAddrOp_Int = 577+primOpTag WriteOffAddrOp_Word = 578+primOpTag WriteOffAddrOp_Addr = 579+primOpTag WriteOffAddrOp_Float = 580+primOpTag WriteOffAddrOp_Double = 581+primOpTag WriteOffAddrOp_StablePtr = 582+primOpTag WriteOffAddrOp_Int8 = 583+primOpTag WriteOffAddrOp_Word8 = 584+primOpTag WriteOffAddrOp_Int16 = 585+primOpTag WriteOffAddrOp_Word16 = 586+primOpTag WriteOffAddrOp_Int32 = 587+primOpTag WriteOffAddrOp_Word32 = 588+primOpTag WriteOffAddrOp_Int64 = 589+primOpTag WriteOffAddrOp_Word64 = 590+primOpTag WriteOffAddrOp_Word8AsChar = 591+primOpTag WriteOffAddrOp_Word8AsWideChar = 592+primOpTag WriteOffAddrOp_Word8AsInt = 593+primOpTag WriteOffAddrOp_Word8AsWord = 594+primOpTag WriteOffAddrOp_Word8AsAddr = 595+primOpTag WriteOffAddrOp_Word8AsFloat = 596+primOpTag WriteOffAddrOp_Word8AsDouble = 597+primOpTag WriteOffAddrOp_Word8AsStablePtr = 598+primOpTag WriteOffAddrOp_Word8AsInt16 = 599+primOpTag WriteOffAddrOp_Word8AsWord16 = 600+primOpTag WriteOffAddrOp_Word8AsInt32 = 601+primOpTag WriteOffAddrOp_Word8AsWord32 = 602+primOpTag WriteOffAddrOp_Word8AsInt64 = 603+primOpTag WriteOffAddrOp_Word8AsWord64 = 604+primOpTag InterlockedExchange_Addr = 605+primOpTag InterlockedExchange_Word = 606+primOpTag CasAddrOp_Addr = 607+primOpTag CasAddrOp_Word = 608+primOpTag CasAddrOp_Word8 = 609+primOpTag CasAddrOp_Word16 = 610+primOpTag CasAddrOp_Word32 = 611+primOpTag CasAddrOp_Word64 = 612+primOpTag FetchAddAddrOp_Word = 613+primOpTag FetchSubAddrOp_Word = 614+primOpTag FetchAndAddrOp_Word = 615+primOpTag FetchNandAddrOp_Word = 616+primOpTag FetchOrAddrOp_Word = 617+primOpTag FetchXorAddrOp_Word = 618+primOpTag AtomicReadAddrOp_Word = 619+primOpTag AtomicWriteAddrOp_Word = 620+primOpTag NewMutVarOp = 621+primOpTag ReadMutVarOp = 622+primOpTag WriteMutVarOp = 623+primOpTag AtomicSwapMutVarOp = 624+primOpTag AtomicModifyMutVar2Op = 625+primOpTag AtomicModifyMutVar_Op = 626+primOpTag CasMutVarOp = 627+primOpTag CatchOp = 628+primOpTag RaiseOp = 629+primOpTag RaiseUnderflowOp = 630+primOpTag RaiseOverflowOp = 631+primOpTag RaiseDivZeroOp = 632+primOpTag RaiseIOOp = 633+primOpTag MaskAsyncExceptionsOp = 634+primOpTag MaskUninterruptibleOp = 635+primOpTag UnmaskAsyncExceptionsOp = 636+primOpTag MaskStatus = 637+primOpTag NewPromptTagOp = 638+primOpTag PromptOp = 639+primOpTag Control0Op = 640+primOpTag AtomicallyOp = 641+primOpTag RetryOp = 642+primOpTag CatchRetryOp = 643+primOpTag CatchSTMOp = 644+primOpTag NewTVarOp = 645+primOpTag ReadTVarOp = 646+primOpTag ReadTVarIOOp = 647+primOpTag WriteTVarOp = 648+primOpTag NewMVarOp = 649+primOpTag TakeMVarOp = 650+primOpTag TryTakeMVarOp = 651+primOpTag PutMVarOp = 652+primOpTag TryPutMVarOp = 653+primOpTag ReadMVarOp = 654+primOpTag TryReadMVarOp = 655+primOpTag IsEmptyMVarOp = 656+primOpTag DelayOp = 657+primOpTag WaitReadOp = 658+primOpTag WaitWriteOp = 659+primOpTag ForkOp = 660+primOpTag ForkOnOp = 661+primOpTag KillThreadOp = 662+primOpTag YieldOp = 663+primOpTag MyThreadIdOp = 664+primOpTag LabelThreadOp = 665+primOpTag IsCurrentThreadBoundOp = 666+primOpTag NoDuplicateOp = 667+primOpTag GetThreadLabelOp = 668+primOpTag ThreadStatusOp = 669+primOpTag ListThreadsOp = 670+primOpTag MkWeakOp = 671+primOpTag MkWeakNoFinalizerOp = 672+primOpTag AddCFinalizerToWeakOp = 673+primOpTag DeRefWeakOp = 674+primOpTag FinalizeWeakOp = 675+primOpTag TouchOp = 676+primOpTag MakeStablePtrOp = 677+primOpTag DeRefStablePtrOp = 678+primOpTag EqStablePtrOp = 679+primOpTag MakeStableNameOp = 680+primOpTag StableNameToIntOp = 681+primOpTag CompactNewOp = 682+primOpTag CompactResizeOp = 683+primOpTag CompactContainsOp = 684+primOpTag CompactContainsAnyOp = 685+primOpTag CompactGetFirstBlockOp = 686+primOpTag CompactGetNextBlockOp = 687+primOpTag CompactAllocateBlockOp = 688+primOpTag CompactFixupPointersOp = 689+primOpTag CompactAdd = 690+primOpTag CompactAddWithSharing = 691+primOpTag CompactSize = 692+primOpTag ReallyUnsafePtrEqualityOp = 693+primOpTag ParOp = 694+primOpTag SparkOp = 695+primOpTag GetSparkOp = 696+primOpTag NumSparks = 697+primOpTag KeepAliveOp = 698+primOpTag DataToTagSmallOp = 699+primOpTag DataToTagLargeOp = 700+primOpTag TagToEnumOp = 701+primOpTag AddrToAnyOp = 702+primOpTag AnyToAddrOp = 703+primOpTag MkApUpd0_Op = 704+primOpTag NewBCOOp = 705+primOpTag UnpackClosureOp = 706+primOpTag ClosureSizeOp = 707+primOpTag GetApStackValOp = 708+primOpTag GetCCSOfOp = 709+primOpTag GetCurrentCCSOp = 710+primOpTag ClearCCSOp = 711+primOpTag AnnotateStackOp = 712+primOpTag WhereFromOp = 713+primOpTag TraceEventOp = 714+primOpTag TraceEventBinaryOp = 715+primOpTag TraceMarkerOp = 716+primOpTag SetThreadAllocationCounter = 717+primOpTag SetOtherThreadAllocationCounter = 718+primOpTag (VecBroadcastOp IntVec 16 W8) = 719+primOpTag (VecBroadcastOp IntVec 8 W16) = 720+primOpTag (VecBroadcastOp IntVec 4 W32) = 721+primOpTag (VecBroadcastOp IntVec 2 W64) = 722+primOpTag (VecBroadcastOp IntVec 32 W8) = 723+primOpTag (VecBroadcastOp IntVec 16 W16) = 724+primOpTag (VecBroadcastOp IntVec 8 W32) = 725+primOpTag (VecBroadcastOp IntVec 4 W64) = 726+primOpTag (VecBroadcastOp IntVec 64 W8) = 727+primOpTag (VecBroadcastOp IntVec 32 W16) = 728+primOpTag (VecBroadcastOp IntVec 16 W32) = 729+primOpTag (VecBroadcastOp IntVec 8 W64) = 730+primOpTag (VecBroadcastOp WordVec 16 W8) = 731+primOpTag (VecBroadcastOp WordVec 8 W16) = 732+primOpTag (VecBroadcastOp WordVec 4 W32) = 733+primOpTag (VecBroadcastOp WordVec 2 W64) = 734+primOpTag (VecBroadcastOp WordVec 32 W8) = 735+primOpTag (VecBroadcastOp WordVec 16 W16) = 736+primOpTag (VecBroadcastOp WordVec 8 W32) = 737+primOpTag (VecBroadcastOp WordVec 4 W64) = 738+primOpTag (VecBroadcastOp WordVec 64 W8) = 739+primOpTag (VecBroadcastOp WordVec 32 W16) = 740+primOpTag (VecBroadcastOp WordVec 16 W32) = 741+primOpTag (VecBroadcastOp WordVec 8 W64) = 742+primOpTag (VecBroadcastOp FloatVec 4 W32) = 743+primOpTag (VecBroadcastOp FloatVec 2 W64) = 744+primOpTag (VecBroadcastOp FloatVec 8 W32) = 745+primOpTag (VecBroadcastOp FloatVec 4 W64) = 746+primOpTag (VecBroadcastOp FloatVec 16 W32) = 747+primOpTag (VecBroadcastOp FloatVec 8 W64) = 748+primOpTag (VecPackOp IntVec 16 W8) = 749+primOpTag (VecPackOp IntVec 8 W16) = 750+primOpTag (VecPackOp IntVec 4 W32) = 751+primOpTag (VecPackOp IntVec 2 W64) = 752+primOpTag (VecPackOp IntVec 32 W8) = 753+primOpTag (VecPackOp IntVec 16 W16) = 754+primOpTag (VecPackOp IntVec 8 W32) = 755+primOpTag (VecPackOp IntVec 4 W64) = 756+primOpTag (VecPackOp IntVec 64 W8) = 757+primOpTag (VecPackOp IntVec 32 W16) = 758+primOpTag (VecPackOp IntVec 16 W32) = 759+primOpTag (VecPackOp IntVec 8 W64) = 760+primOpTag (VecPackOp WordVec 16 W8) = 761+primOpTag (VecPackOp WordVec 8 W16) = 762+primOpTag (VecPackOp WordVec 4 W32) = 763+primOpTag (VecPackOp WordVec 2 W64) = 764+primOpTag (VecPackOp WordVec 32 W8) = 765+primOpTag (VecPackOp WordVec 16 W16) = 766+primOpTag (VecPackOp WordVec 8 W32) = 767+primOpTag (VecPackOp WordVec 4 W64) = 768+primOpTag (VecPackOp WordVec 64 W8) = 769+primOpTag (VecPackOp WordVec 32 W16) = 770+primOpTag (VecPackOp WordVec 16 W32) = 771+primOpTag (VecPackOp WordVec 8 W64) = 772+primOpTag (VecPackOp FloatVec 4 W32) = 773+primOpTag (VecPackOp FloatVec 2 W64) = 774+primOpTag (VecPackOp FloatVec 8 W32) = 775+primOpTag (VecPackOp FloatVec 4 W64) = 776+primOpTag (VecPackOp FloatVec 16 W32) = 777+primOpTag (VecPackOp FloatVec 8 W64) = 778+primOpTag (VecUnpackOp IntVec 16 W8) = 779+primOpTag (VecUnpackOp IntVec 8 W16) = 780+primOpTag (VecUnpackOp IntVec 4 W32) = 781+primOpTag (VecUnpackOp IntVec 2 W64) = 782+primOpTag (VecUnpackOp IntVec 32 W8) = 783+primOpTag (VecUnpackOp IntVec 16 W16) = 784+primOpTag (VecUnpackOp IntVec 8 W32) = 785+primOpTag (VecUnpackOp IntVec 4 W64) = 786+primOpTag (VecUnpackOp IntVec 64 W8) = 787+primOpTag (VecUnpackOp IntVec 32 W16) = 788+primOpTag (VecUnpackOp IntVec 16 W32) = 789+primOpTag (VecUnpackOp IntVec 8 W64) = 790+primOpTag (VecUnpackOp WordVec 16 W8) = 791+primOpTag (VecUnpackOp WordVec 8 W16) = 792+primOpTag (VecUnpackOp WordVec 4 W32) = 793+primOpTag (VecUnpackOp WordVec 2 W64) = 794+primOpTag (VecUnpackOp WordVec 32 W8) = 795+primOpTag (VecUnpackOp WordVec 16 W16) = 796+primOpTag (VecUnpackOp WordVec 8 W32) = 797+primOpTag (VecUnpackOp WordVec 4 W64) = 798+primOpTag (VecUnpackOp WordVec 64 W8) = 799+primOpTag (VecUnpackOp WordVec 32 W16) = 800+primOpTag (VecUnpackOp WordVec 16 W32) = 801+primOpTag (VecUnpackOp WordVec 8 W64) = 802+primOpTag (VecUnpackOp FloatVec 4 W32) = 803+primOpTag (VecUnpackOp FloatVec 2 W64) = 804+primOpTag (VecUnpackOp FloatVec 8 W32) = 805+primOpTag (VecUnpackOp FloatVec 4 W64) = 806+primOpTag (VecUnpackOp FloatVec 16 W32) = 807+primOpTag (VecUnpackOp FloatVec 8 W64) = 808+primOpTag (VecInsertOp IntVec 16 W8) = 809+primOpTag (VecInsertOp IntVec 8 W16) = 810+primOpTag (VecInsertOp IntVec 4 W32) = 811+primOpTag (VecInsertOp IntVec 2 W64) = 812+primOpTag (VecInsertOp IntVec 32 W8) = 813+primOpTag (VecInsertOp IntVec 16 W16) = 814+primOpTag (VecInsertOp IntVec 8 W32) = 815+primOpTag (VecInsertOp IntVec 4 W64) = 816+primOpTag (VecInsertOp IntVec 64 W8) = 817+primOpTag (VecInsertOp IntVec 32 W16) = 818+primOpTag (VecInsertOp IntVec 16 W32) = 819+primOpTag (VecInsertOp IntVec 8 W64) = 820+primOpTag (VecInsertOp WordVec 16 W8) = 821+primOpTag (VecInsertOp WordVec 8 W16) = 822+primOpTag (VecInsertOp WordVec 4 W32) = 823+primOpTag (VecInsertOp WordVec 2 W64) = 824+primOpTag (VecInsertOp WordVec 32 W8) = 825+primOpTag (VecInsertOp WordVec 16 W16) = 826+primOpTag (VecInsertOp WordVec 8 W32) = 827+primOpTag (VecInsertOp WordVec 4 W64) = 828+primOpTag (VecInsertOp WordVec 64 W8) = 829+primOpTag (VecInsertOp WordVec 32 W16) = 830+primOpTag (VecInsertOp WordVec 16 W32) = 831+primOpTag (VecInsertOp WordVec 8 W64) = 832+primOpTag (VecInsertOp FloatVec 4 W32) = 833+primOpTag (VecInsertOp FloatVec 2 W64) = 834+primOpTag (VecInsertOp FloatVec 8 W32) = 835+primOpTag (VecInsertOp FloatVec 4 W64) = 836+primOpTag (VecInsertOp FloatVec 16 W32) = 837+primOpTag (VecInsertOp FloatVec 8 W64) = 838+primOpTag (VecAddOp IntVec 16 W8) = 839+primOpTag (VecAddOp IntVec 8 W16) = 840+primOpTag (VecAddOp IntVec 4 W32) = 841+primOpTag (VecAddOp IntVec 2 W64) = 842+primOpTag (VecAddOp IntVec 32 W8) = 843+primOpTag (VecAddOp IntVec 16 W16) = 844+primOpTag (VecAddOp IntVec 8 W32) = 845+primOpTag (VecAddOp IntVec 4 W64) = 846+primOpTag (VecAddOp IntVec 64 W8) = 847+primOpTag (VecAddOp IntVec 32 W16) = 848+primOpTag (VecAddOp IntVec 16 W32) = 849+primOpTag (VecAddOp IntVec 8 W64) = 850+primOpTag (VecAddOp WordVec 16 W8) = 851+primOpTag (VecAddOp WordVec 8 W16) = 852+primOpTag (VecAddOp WordVec 4 W32) = 853+primOpTag (VecAddOp WordVec 2 W64) = 854+primOpTag (VecAddOp WordVec 32 W8) = 855+primOpTag (VecAddOp WordVec 16 W16) = 856+primOpTag (VecAddOp WordVec 8 W32) = 857+primOpTag (VecAddOp WordVec 4 W64) = 858+primOpTag (VecAddOp WordVec 64 W8) = 859+primOpTag (VecAddOp WordVec 32 W16) = 860+primOpTag (VecAddOp WordVec 16 W32) = 861+primOpTag (VecAddOp WordVec 8 W64) = 862+primOpTag (VecAddOp FloatVec 4 W32) = 863+primOpTag (VecAddOp FloatVec 2 W64) = 864+primOpTag (VecAddOp FloatVec 8 W32) = 865+primOpTag (VecAddOp FloatVec 4 W64) = 866+primOpTag (VecAddOp FloatVec 16 W32) = 867+primOpTag (VecAddOp FloatVec 8 W64) = 868+primOpTag (VecSubOp IntVec 16 W8) = 869+primOpTag (VecSubOp IntVec 8 W16) = 870+primOpTag (VecSubOp IntVec 4 W32) = 871+primOpTag (VecSubOp IntVec 2 W64) = 872+primOpTag (VecSubOp IntVec 32 W8) = 873+primOpTag (VecSubOp IntVec 16 W16) = 874+primOpTag (VecSubOp IntVec 8 W32) = 875+primOpTag (VecSubOp IntVec 4 W64) = 876+primOpTag (VecSubOp IntVec 64 W8) = 877+primOpTag (VecSubOp IntVec 32 W16) = 878+primOpTag (VecSubOp IntVec 16 W32) = 879+primOpTag (VecSubOp IntVec 8 W64) = 880+primOpTag (VecSubOp WordVec 16 W8) = 881+primOpTag (VecSubOp WordVec 8 W16) = 882+primOpTag (VecSubOp WordVec 4 W32) = 883+primOpTag (VecSubOp WordVec 2 W64) = 884+primOpTag (VecSubOp WordVec 32 W8) = 885+primOpTag (VecSubOp WordVec 16 W16) = 886+primOpTag (VecSubOp WordVec 8 W32) = 887+primOpTag (VecSubOp WordVec 4 W64) = 888+primOpTag (VecSubOp WordVec 64 W8) = 889+primOpTag (VecSubOp WordVec 32 W16) = 890+primOpTag (VecSubOp WordVec 16 W32) = 891+primOpTag (VecSubOp WordVec 8 W64) = 892+primOpTag (VecSubOp FloatVec 4 W32) = 893+primOpTag (VecSubOp FloatVec 2 W64) = 894+primOpTag (VecSubOp FloatVec 8 W32) = 895+primOpTag (VecSubOp FloatVec 4 W64) = 896+primOpTag (VecSubOp FloatVec 16 W32) = 897+primOpTag (VecSubOp FloatVec 8 W64) = 898+primOpTag (VecMulOp IntVec 16 W8) = 899+primOpTag (VecMulOp IntVec 8 W16) = 900+primOpTag (VecMulOp IntVec 4 W32) = 901+primOpTag (VecMulOp IntVec 2 W64) = 902+primOpTag (VecMulOp IntVec 32 W8) = 903+primOpTag (VecMulOp IntVec 16 W16) = 904+primOpTag (VecMulOp IntVec 8 W32) = 905+primOpTag (VecMulOp IntVec 4 W64) = 906+primOpTag (VecMulOp IntVec 64 W8) = 907+primOpTag (VecMulOp IntVec 32 W16) = 908+primOpTag (VecMulOp IntVec 16 W32) = 909+primOpTag (VecMulOp IntVec 8 W64) = 910+primOpTag (VecMulOp WordVec 16 W8) = 911+primOpTag (VecMulOp WordVec 8 W16) = 912+primOpTag (VecMulOp WordVec 4 W32) = 913+primOpTag (VecMulOp WordVec 2 W64) = 914+primOpTag (VecMulOp WordVec 32 W8) = 915+primOpTag (VecMulOp WordVec 16 W16) = 916+primOpTag (VecMulOp WordVec 8 W32) = 917+primOpTag (VecMulOp WordVec 4 W64) = 918+primOpTag (VecMulOp WordVec 64 W8) = 919+primOpTag (VecMulOp WordVec 32 W16) = 920+primOpTag (VecMulOp WordVec 16 W32) = 921+primOpTag (VecMulOp WordVec 8 W64) = 922+primOpTag (VecMulOp FloatVec 4 W32) = 923+primOpTag (VecMulOp FloatVec 2 W64) = 924+primOpTag (VecMulOp FloatVec 8 W32) = 925+primOpTag (VecMulOp FloatVec 4 W64) = 926+primOpTag (VecMulOp FloatVec 16 W32) = 927+primOpTag (VecMulOp FloatVec 8 W64) = 928+primOpTag (VecDivOp FloatVec 4 W32) = 929+primOpTag (VecDivOp FloatVec 2 W64) = 930+primOpTag (VecDivOp FloatVec 8 W32) = 931+primOpTag (VecDivOp FloatVec 4 W64) = 932+primOpTag (VecDivOp FloatVec 16 W32) = 933+primOpTag (VecDivOp FloatVec 8 W64) = 934+primOpTag (VecQuotOp IntVec 16 W8) = 935+primOpTag (VecQuotOp IntVec 8 W16) = 936+primOpTag (VecQuotOp IntVec 4 W32) = 937+primOpTag (VecQuotOp IntVec 2 W64) = 938+primOpTag (VecQuotOp IntVec 32 W8) = 939+primOpTag (VecQuotOp IntVec 16 W16) = 940+primOpTag (VecQuotOp IntVec 8 W32) = 941+primOpTag (VecQuotOp IntVec 4 W64) = 942+primOpTag (VecQuotOp IntVec 64 W8) = 943+primOpTag (VecQuotOp IntVec 32 W16) = 944+primOpTag (VecQuotOp IntVec 16 W32) = 945+primOpTag (VecQuotOp IntVec 8 W64) = 946+primOpTag (VecQuotOp WordVec 16 W8) = 947+primOpTag (VecQuotOp WordVec 8 W16) = 948+primOpTag (VecQuotOp WordVec 4 W32) = 949+primOpTag (VecQuotOp WordVec 2 W64) = 950+primOpTag (VecQuotOp WordVec 32 W8) = 951+primOpTag (VecQuotOp WordVec 16 W16) = 952+primOpTag (VecQuotOp WordVec 8 W32) = 953+primOpTag (VecQuotOp WordVec 4 W64) = 954+primOpTag (VecQuotOp WordVec 64 W8) = 955+primOpTag (VecQuotOp WordVec 32 W16) = 956+primOpTag (VecQuotOp WordVec 16 W32) = 957+primOpTag (VecQuotOp WordVec 8 W64) = 958+primOpTag (VecRemOp IntVec 16 W8) = 959+primOpTag (VecRemOp IntVec 8 W16) = 960+primOpTag (VecRemOp IntVec 4 W32) = 961+primOpTag (VecRemOp IntVec 2 W64) = 962+primOpTag (VecRemOp IntVec 32 W8) = 963+primOpTag (VecRemOp IntVec 16 W16) = 964+primOpTag (VecRemOp IntVec 8 W32) = 965+primOpTag (VecRemOp IntVec 4 W64) = 966+primOpTag (VecRemOp IntVec 64 W8) = 967+primOpTag (VecRemOp IntVec 32 W16) = 968+primOpTag (VecRemOp IntVec 16 W32) = 969+primOpTag (VecRemOp IntVec 8 W64) = 970+primOpTag (VecRemOp WordVec 16 W8) = 971+primOpTag (VecRemOp WordVec 8 W16) = 972+primOpTag (VecRemOp WordVec 4 W32) = 973+primOpTag (VecRemOp WordVec 2 W64) = 974+primOpTag (VecRemOp WordVec 32 W8) = 975+primOpTag (VecRemOp WordVec 16 W16) = 976+primOpTag (VecRemOp WordVec 8 W32) = 977+primOpTag (VecRemOp WordVec 4 W64) = 978+primOpTag (VecRemOp WordVec 64 W8) = 979+primOpTag (VecRemOp WordVec 32 W16) = 980+primOpTag (VecRemOp WordVec 16 W32) = 981+primOpTag (VecRemOp WordVec 8 W64) = 982+primOpTag (VecNegOp IntVec 16 W8) = 983+primOpTag (VecNegOp IntVec 8 W16) = 984+primOpTag (VecNegOp IntVec 4 W32) = 985+primOpTag (VecNegOp IntVec 2 W64) = 986+primOpTag (VecNegOp IntVec 32 W8) = 987+primOpTag (VecNegOp IntVec 16 W16) = 988+primOpTag (VecNegOp IntVec 8 W32) = 989+primOpTag (VecNegOp IntVec 4 W64) = 990+primOpTag (VecNegOp IntVec 64 W8) = 991+primOpTag (VecNegOp IntVec 32 W16) = 992+primOpTag (VecNegOp IntVec 16 W32) = 993+primOpTag (VecNegOp IntVec 8 W64) = 994+primOpTag (VecNegOp FloatVec 4 W32) = 995+primOpTag (VecNegOp FloatVec 2 W64) = 996+primOpTag (VecNegOp FloatVec 8 W32) = 997+primOpTag (VecNegOp FloatVec 4 W64) = 998+primOpTag (VecNegOp FloatVec 16 W32) = 999+primOpTag (VecNegOp FloatVec 8 W64) = 1000+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 1001+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 1002+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 1003+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 1004+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 1005+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 1006+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 1007+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 1008+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 1009+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 1010+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 1011+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 1012+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 1013+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 1014+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 1015+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 1016+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 1017+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 1018+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 1019+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 1020+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 1021+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 1022+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 1023+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 1024+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 1025+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 1026+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 1027+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 1028+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 1029+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 1030+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 1031+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 1032+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 1033+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 1034+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 1035+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 1036+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 1037+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 1038+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 1039+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 1040+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 1041+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 1042+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 1043+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 1044+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 1045+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 1046+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 1047+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 1048+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 1049+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 1050+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 1051+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 1052+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 1053+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 1054+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 1055+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1056+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1057+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1058+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1059+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1060+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1061+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1062+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1063+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1064+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1065+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1066+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1067+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1068+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1069+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1070+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1071+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1072+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1073+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1074+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1075+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1076+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1077+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1078+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1079+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1080+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1081+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1082+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1083+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1084+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1085+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1086+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1087+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1088+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1089+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1090+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1091+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1092+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1093+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1094+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1095+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1096+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1097+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1098+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1099+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1100+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1101+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1102+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1103+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1104+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1105+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1106+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1107+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1108+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1109+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1110+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1111+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1112+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1113+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1114+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1115+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1116+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1117+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1118+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1119+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1120+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1121+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1122+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1123+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1124+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1125+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1126+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1127+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1128+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1129+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1130+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1131+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1132+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1133+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1134+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1135+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1136+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1137+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1138+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1139+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1140+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1141+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1142+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1143+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1144+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1145+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1146+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1147+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1148+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1149+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1150+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1151+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1152+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1153+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1154+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1155+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1156+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1157+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1158+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1159+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1160+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1161+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1162+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1163+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1164+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1165+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1166+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1167+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1168+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1169+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1170+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1171+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1172+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1173+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1174+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1175+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1176+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1177+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1178+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1179+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1180+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1181+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1182+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1183+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1184+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1185+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1186+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1187+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1188+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1189+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1190+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1191+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1192+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1193+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1194+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1195+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1196+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1197+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1198+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1199+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1200+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1201+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1202+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1203+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1204+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1205+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1206+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1207+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1208+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1209+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1210+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1211+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1212+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1213+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1214+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1215+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1216+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1217+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1218+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1219+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1220+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1221+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1222+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1223+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1224+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1225+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1226+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1227+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1228+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1229+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1230+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1231+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1232+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1233+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1234+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1235+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1236+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1237+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1238+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1239+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1240+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1241+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1242+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1243+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1244+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1245+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1246+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1247+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1248+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1249+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1250+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1251+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1252+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1253+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1254+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1255+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1256+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1257+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1258+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1259+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1260+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1261+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1262+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1263+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1264+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1265+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1266+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1267+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1268+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1269+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1270+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1271+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1272+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1273+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1274+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1275+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1276+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1277+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1278+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1279+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1280+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1281+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1282+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1283+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1284+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1285+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1286+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1287+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1288+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1289+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1290+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1291+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1292+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1293+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1294+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1295+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1296+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1297+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1298+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1299+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1300+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1301+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1302+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1303+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1304+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1305+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1306+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1307+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1308+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1309+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1310+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1311+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1312+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1313+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1314+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1315+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1316+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1317+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1318+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1319+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1320+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1321+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1322+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1323+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1324+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1325+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1326+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1327+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1328+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1329+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1330+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1331+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1332+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1333+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1334+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1335+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1336+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1337+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1338+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1339+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1340+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1341+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1342+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1343+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1344+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1345+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1346+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1347+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1348+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1349+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1350+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1351+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1352+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1353+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1354+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1355+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1356+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1357+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1358+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1359+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1360+primOpTag (VecFMAdd FloatVec 4 W32) = 1361+primOpTag (VecFMAdd FloatVec 2 W64) = 1362+primOpTag (VecFMAdd FloatVec 8 W32) = 1363+primOpTag (VecFMAdd FloatVec 4 W64) = 1364+primOpTag (VecFMAdd FloatVec 16 W32) = 1365+primOpTag (VecFMAdd FloatVec 8 W64) = 1366+primOpTag (VecFMSub FloatVec 4 W32) = 1367+primOpTag (VecFMSub FloatVec 2 W64) = 1368+primOpTag (VecFMSub FloatVec 8 W32) = 1369+primOpTag (VecFMSub FloatVec 4 W64) = 1370+primOpTag (VecFMSub FloatVec 16 W32) = 1371+primOpTag (VecFMSub FloatVec 8 W64) = 1372+primOpTag (VecFNMAdd FloatVec 4 W32) = 1373+primOpTag (VecFNMAdd FloatVec 2 W64) = 1374+primOpTag (VecFNMAdd FloatVec 8 W32) = 1375+primOpTag (VecFNMAdd FloatVec 4 W64) = 1376+primOpTag (VecFNMAdd FloatVec 16 W32) = 1377+primOpTag (VecFNMAdd FloatVec 8 W64) = 1378+primOpTag (VecFNMSub FloatVec 4 W32) = 1379+primOpTag (VecFNMSub FloatVec 2 W64) = 1380+primOpTag (VecFNMSub FloatVec 8 W32) = 1381+primOpTag (VecFNMSub FloatVec 4 W64) = 1382+primOpTag (VecFNMSub FloatVec 16 W32) = 1383+primOpTag (VecFNMSub FloatVec 8 W64) = 1384+primOpTag (VecShuffleOp IntVec 16 W8) = 1385+primOpTag (VecShuffleOp IntVec 8 W16) = 1386+primOpTag (VecShuffleOp IntVec 4 W32) = 1387+primOpTag (VecShuffleOp IntVec 2 W64) = 1388+primOpTag (VecShuffleOp IntVec 32 W8) = 1389+primOpTag (VecShuffleOp IntVec 16 W16) = 1390+primOpTag (VecShuffleOp IntVec 8 W32) = 1391+primOpTag (VecShuffleOp IntVec 4 W64) = 1392+primOpTag (VecShuffleOp IntVec 64 W8) = 1393+primOpTag (VecShuffleOp IntVec 32 W16) = 1394+primOpTag (VecShuffleOp IntVec 16 W32) = 1395+primOpTag (VecShuffleOp IntVec 8 W64) = 1396+primOpTag (VecShuffleOp WordVec 16 W8) = 1397+primOpTag (VecShuffleOp WordVec 8 W16) = 1398+primOpTag (VecShuffleOp WordVec 4 W32) = 1399+primOpTag (VecShuffleOp WordVec 2 W64) = 1400+primOpTag (VecShuffleOp WordVec 32 W8) = 1401+primOpTag (VecShuffleOp WordVec 16 W16) = 1402+primOpTag (VecShuffleOp WordVec 8 W32) = 1403+primOpTag (VecShuffleOp WordVec 4 W64) = 1404+primOpTag (VecShuffleOp WordVec 64 W8) = 1405+primOpTag (VecShuffleOp WordVec 32 W16) = 1406+primOpTag (VecShuffleOp WordVec 16 W32) = 1407+primOpTag (VecShuffleOp WordVec 8 W64) = 1408+primOpTag (VecShuffleOp FloatVec 4 W32) = 1409+primOpTag (VecShuffleOp FloatVec 2 W64) = 1410+primOpTag (VecShuffleOp FloatVec 8 W32) = 1411+primOpTag (VecShuffleOp FloatVec 4 W64) = 1412+primOpTag (VecShuffleOp FloatVec 16 W32) = 1413+primOpTag (VecShuffleOp FloatVec 8 W64) = 1414+primOpTag (VecMinOp IntVec 16 W8) = 1415+primOpTag (VecMinOp IntVec 8 W16) = 1416+primOpTag (VecMinOp IntVec 4 W32) = 1417+primOpTag (VecMinOp IntVec 2 W64) = 1418+primOpTag (VecMinOp IntVec 32 W8) = 1419+primOpTag (VecMinOp IntVec 16 W16) = 1420+primOpTag (VecMinOp IntVec 8 W32) = 1421+primOpTag (VecMinOp IntVec 4 W64) = 1422+primOpTag (VecMinOp IntVec 64 W8) = 1423+primOpTag (VecMinOp IntVec 32 W16) = 1424+primOpTag (VecMinOp IntVec 16 W32) = 1425+primOpTag (VecMinOp IntVec 8 W64) = 1426+primOpTag (VecMinOp WordVec 16 W8) = 1427+primOpTag (VecMinOp WordVec 8 W16) = 1428+primOpTag (VecMinOp WordVec 4 W32) = 1429+primOpTag (VecMinOp WordVec 2 W64) = 1430+primOpTag (VecMinOp WordVec 32 W8) = 1431+primOpTag (VecMinOp WordVec 16 W16) = 1432+primOpTag (VecMinOp WordVec 8 W32) = 1433+primOpTag (VecMinOp WordVec 4 W64) = 1434+primOpTag (VecMinOp WordVec 64 W8) = 1435+primOpTag (VecMinOp WordVec 32 W16) = 1436+primOpTag (VecMinOp WordVec 16 W32) = 1437+primOpTag (VecMinOp WordVec 8 W64) = 1438+primOpTag (VecMinOp FloatVec 4 W32) = 1439+primOpTag (VecMinOp FloatVec 2 W64) = 1440+primOpTag (VecMinOp FloatVec 8 W32) = 1441+primOpTag (VecMinOp FloatVec 4 W64) = 1442+primOpTag (VecMinOp FloatVec 16 W32) = 1443+primOpTag (VecMinOp FloatVec 8 W64) = 1444+primOpTag (VecMaxOp IntVec 16 W8) = 1445+primOpTag (VecMaxOp IntVec 8 W16) = 1446+primOpTag (VecMaxOp IntVec 4 W32) = 1447+primOpTag (VecMaxOp IntVec 2 W64) = 1448+primOpTag (VecMaxOp IntVec 32 W8) = 1449+primOpTag (VecMaxOp IntVec 16 W16) = 1450+primOpTag (VecMaxOp IntVec 8 W32) = 1451+primOpTag (VecMaxOp IntVec 4 W64) = 1452+primOpTag (VecMaxOp IntVec 64 W8) = 1453+primOpTag (VecMaxOp IntVec 32 W16) = 1454+primOpTag (VecMaxOp IntVec 16 W32) = 1455+primOpTag (VecMaxOp IntVec 8 W64) = 1456+primOpTag (VecMaxOp WordVec 16 W8) = 1457+primOpTag (VecMaxOp WordVec 8 W16) = 1458+primOpTag (VecMaxOp WordVec 4 W32) = 1459+primOpTag (VecMaxOp WordVec 2 W64) = 1460+primOpTag (VecMaxOp WordVec 32 W8) = 1461+primOpTag (VecMaxOp WordVec 16 W16) = 1462+primOpTag (VecMaxOp WordVec 8 W32) = 1463+primOpTag (VecMaxOp WordVec 4 W64) = 1464+primOpTag (VecMaxOp WordVec 64 W8) = 1465+primOpTag (VecMaxOp WordVec 32 W16) = 1466+primOpTag (VecMaxOp WordVec 16 W32) = 1467+primOpTag (VecMaxOp WordVec 8 W64) = 1468+primOpTag (VecMaxOp FloatVec 4 W32) = 1469+primOpTag (VecMaxOp FloatVec 2 W64) = 1470+primOpTag (VecMaxOp FloatVec 8 W32) = 1471+primOpTag (VecMaxOp FloatVec 4 W64) = 1472+primOpTag (VecMaxOp FloatVec 16 W32) = 1473+primOpTag (VecMaxOp FloatVec 8 W64) = 1474+primOpTag PrefetchByteArrayOp3 = 1475+primOpTag PrefetchMutableByteArrayOp3 = 1476+primOpTag PrefetchAddrOp3 = 1477+primOpTag PrefetchValueOp3 = 1478+primOpTag PrefetchByteArrayOp2 = 1479+primOpTag PrefetchMutableByteArrayOp2 = 1480+primOpTag PrefetchAddrOp2 = 1481+primOpTag PrefetchValueOp2 = 1482+primOpTag PrefetchByteArrayOp1 = 1483+primOpTag PrefetchMutableByteArrayOp1 = 1484+primOpTag PrefetchAddrOp1 = 1485+primOpTag PrefetchValueOp1 = 1486+primOpTag PrefetchByteArrayOp0 = 1487+primOpTag PrefetchMutableByteArrayOp0 = 1488+primOpTag PrefetchAddrOp0 = 1489+primOpTag PrefetchValueOp0 = 1490
ghc-lib/stage0/lib/llvm-targets view
@@ -1,4 +1,5 @@ [("x86_64-unknown-windows-gnu", ("e-m:w-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("aarch64-unknown-windows-gnu", ("e-m:w-p:64:64-i32:32-i64:64-i128:128-n32:64-S128-Fn32", "generic", "+v8a +fp-armv8 +neon")) ,("arm-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
ghc-lib/stage0/lib/settings view
@@ -44,9 +44,10 @@ ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM llvm-as command", "clang-19")+,("LLVM llvm-as flags", "") ,("Use inplace MinGW toolchain", "NO") ,("target RTS linker only supports shared libraries", "NO")-,("Use interpreter", "YES")+,("Use interpreter", "NO") ,("Support SMP", "YES") ,("RTS ways", "v thr thr_debug thr_debug_p thr_debug_p_dyn thr_debug_dyn thr_p thr_p_dyn thr_dyn debug debug_p debug_p_dyn debug_dyn p p_dyn dyn") ,("Tables next to code", "YES")@@ -54,4 +55,5 @@ ,("Use LibFFI", "NO") ,("RTS expects libdw", "NO") ,("Relative Global Package DB", "../../stage1/lib/package.conf.d")+,("base unit-id", "base-4.22.0.0-inplace") ]
+ ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/Prim.hs view
@@ -0,0 +1,9889 @@+{-+This is a generated file (generated by genprimopcode).+It is not code to actually be used. Its only purpose is to be+consumed by haddock.+-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Internal.Prim+-- +-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- GHC's primitive types and operations.+-- Use GHC.Exts from the base package instead of importing this+-- module directly.+--+-----------------------------------------------------------------------------+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE NegativeLiterals #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-}+module GHC.Internal.Prim (+        +{- * The word size story.-}+{-|Haskell98 specifies that signed integers (type 'Int')+         must contain at least 30 bits. GHC always implements+         'Int' using the primitive type 'Int#', whose size equals+         the @MachDeps.h@ constant @WORD\_SIZE\_IN\_BITS@.+         This is normally set based on the RTS @ghcautoconf.h@ parameter+         @SIZEOF\_HSWORD@, i.e., 32 bits on 32-bit machines, 64+         bits on 64-bit machines.++         GHC also implements a primitive unsigned integer type+         'Word#' which always has the same number of bits as 'Int#'.++         In addition, GHC supports families of explicit-sized integers+         and words at 8, 16, 32, and 64 bits, with the usual+         arithmetic operations, comparisons, and a range of+         conversions.++         Finally, there are strongly deprecated primops for coercing+         between 'Addr#', the primitive type of machine+         addresses, and 'Int#'.  These are pretty bogus anyway,+         but will work on existing 32-bit and 64-bit GHC targets; they+         are completely bogus when tag bits are used in 'Int#',+         so are not available in this case.-}+        +{- * Char#-}+{-|Operations on 31-bit characters.-}+        Char#,+        gtChar#,+        geChar#,+        eqChar#,+        neChar#,+        ltChar#,+        leChar#,+        ord#,+        +{- * Int8#-}+{-|Operations on 8-bit integers.-}+        Int8#,+        int8ToInt#,+        intToInt8#,+        negateInt8#,+        plusInt8#,+        subInt8#,+        timesInt8#,+        quotInt8#,+        remInt8#,+        quotRemInt8#,+        uncheckedShiftLInt8#,+        uncheckedShiftRAInt8#,+        uncheckedShiftRLInt8#,+        int8ToWord8#,+        eqInt8#,+        geInt8#,+        gtInt8#,+        leInt8#,+        ltInt8#,+        neInt8#,+        +{- * Word8#-}+{-|Operations on 8-bit unsigned words.-}+        Word8#,+        word8ToWord#,+        wordToWord8#,+        plusWord8#,+        subWord8#,+        timesWord8#,+        quotWord8#,+        remWord8#,+        quotRemWord8#,+        andWord8#,+        orWord8#,+        xorWord8#,+        notWord8#,+        uncheckedShiftLWord8#,+        uncheckedShiftRLWord8#,+        word8ToInt8#,+        eqWord8#,+        geWord8#,+        gtWord8#,+        leWord8#,+        ltWord8#,+        neWord8#,+        +{- * Int16#-}+{-|Operations on 16-bit integers.-}+        Int16#,+        int16ToInt#,+        intToInt16#,+        negateInt16#,+        plusInt16#,+        subInt16#,+        timesInt16#,+        quotInt16#,+        remInt16#,+        quotRemInt16#,+        uncheckedShiftLInt16#,+        uncheckedShiftRAInt16#,+        uncheckedShiftRLInt16#,+        int16ToWord16#,+        eqInt16#,+        geInt16#,+        gtInt16#,+        leInt16#,+        ltInt16#,+        neInt16#,+        +{- * Word16#-}+{-|Operations on 16-bit unsigned words.-}+        Word16#,+        word16ToWord#,+        wordToWord16#,+        plusWord16#,+        subWord16#,+        timesWord16#,+        quotWord16#,+        remWord16#,+        quotRemWord16#,+        andWord16#,+        orWord16#,+        xorWord16#,+        notWord16#,+        uncheckedShiftLWord16#,+        uncheckedShiftRLWord16#,+        word16ToInt16#,+        eqWord16#,+        geWord16#,+        gtWord16#,+        leWord16#,+        ltWord16#,+        neWord16#,+        +{- * Int32#-}+{-|Operations on 32-bit integers.-}+        Int32#,+        int32ToInt#,+        intToInt32#,+        negateInt32#,+        plusInt32#,+        subInt32#,+        timesInt32#,+        quotInt32#,+        remInt32#,+        quotRemInt32#,+        uncheckedShiftLInt32#,+        uncheckedShiftRAInt32#,+        uncheckedShiftRLInt32#,+        int32ToWord32#,+        eqInt32#,+        geInt32#,+        gtInt32#,+        leInt32#,+        ltInt32#,+        neInt32#,+        +{- * Word32#-}+{-|Operations on 32-bit unsigned words.-}+        Word32#,+        word32ToWord#,+        wordToWord32#,+        plusWord32#,+        subWord32#,+        timesWord32#,+        quotWord32#,+        remWord32#,+        quotRemWord32#,+        andWord32#,+        orWord32#,+        xorWord32#,+        notWord32#,+        uncheckedShiftLWord32#,+        uncheckedShiftRLWord32#,+        word32ToInt32#,+        eqWord32#,+        geWord32#,+        gtWord32#,+        leWord32#,+        ltWord32#,+        neWord32#,+        +{- * Int64#-}+{-|Operations on 64-bit signed words.-}+        Int64#,+        int64ToInt#,+        intToInt64#,+        negateInt64#,+        plusInt64#,+        subInt64#,+        timesInt64#,+        quotInt64#,+        remInt64#,+        uncheckedIShiftL64#,+        uncheckedIShiftRA64#,+        uncheckedIShiftRL64#,+        int64ToWord64#,+        eqInt64#,+        geInt64#,+        gtInt64#,+        leInt64#,+        ltInt64#,+        neInt64#,+        +{- * Word64#-}+{-|Operations on 64-bit unsigned words.-}+        Word64#,+        word64ToWord#,+        wordToWord64#,+        plusWord64#,+        subWord64#,+        timesWord64#,+        quotWord64#,+        remWord64#,+        and64#,+        or64#,+        xor64#,+        not64#,+        uncheckedShiftL64#,+        uncheckedShiftRL64#,+        word64ToInt64#,+        eqWord64#,+        geWord64#,+        gtWord64#,+        leWord64#,+        ltWord64#,+        neWord64#,+        +{- * Int#-}+{-|Operations on native-size integers (32+ bits).-}+        Int#,+        (+#),+        (-#),+        (*#),+        timesInt2#,+        mulIntMayOflo#,+        quotInt#,+        remInt#,+        quotRemInt#,+        andI#,+        orI#,+        xorI#,+        notI#,+        negateInt#,+        addIntC#,+        subIntC#,+        (>#),+        (>=#),+        (==#),+        (/=#),+        (<#),+        (<=#),+        chr#,+        int2Word#,+        int2Float#,+        int2Double#,+        word2Float#,+        word2Double#,+        uncheckedIShiftL#,+        uncheckedIShiftRA#,+        uncheckedIShiftRL#,+        +{- * Word#-}+{-|Operations on native-sized unsigned words (32+ bits).-}+        Word#,+        plusWord#,+        addWordC#,+        subWordC#,+        plusWord2#,+        minusWord#,+        timesWord#,+        timesWord2#,+        quotWord#,+        remWord#,+        quotRemWord#,+        quotRemWord2#,+        and#,+        or#,+        xor#,+        not#,+        uncheckedShiftL#,+        uncheckedShiftRL#,+        word2Int#,+        gtWord#,+        geWord#,+        eqWord#,+        neWord#,+        ltWord#,+        leWord#,+        popCnt8#,+        popCnt16#,+        popCnt32#,+        popCnt64#,+        popCnt#,+        pdep8#,+        pdep16#,+        pdep32#,+        pdep64#,+        pdep#,+        pext8#,+        pext16#,+        pext32#,+        pext64#,+        pext#,+        clz8#,+        clz16#,+        clz32#,+        clz64#,+        clz#,+        ctz8#,+        ctz16#,+        ctz32#,+        ctz64#,+        ctz#,+        byteSwap16#,+        byteSwap32#,+        byteSwap64#,+        byteSwap#,+        bitReverse8#,+        bitReverse16#,+        bitReverse32#,+        bitReverse64#,+        bitReverse#,+        +{- * Narrowings-}+{-|Explicit narrowing of native-sized ints or words.-}+        narrow8Int#,+        narrow16Int#,+        narrow32Int#,+        narrow8Word#,+        narrow16Word#,+        narrow32Word#,+        +{- * Double#-}+{-|Operations on double-precision (64 bit) floating-point numbers.-}+        Double#,+        (>##),+        (>=##),+        (==##),+        (/=##),+        (<##),+        (<=##),+        minDouble#,+        maxDouble#,+        (+##),+        (-##),+        (*##),+        (/##),+        negateDouble#,+        fabsDouble#,+        double2Int#,+        double2Float#,+        expDouble#,+        expm1Double#,+        logDouble#,+        log1pDouble#,+        sqrtDouble#,+        sinDouble#,+        cosDouble#,+        tanDouble#,+        asinDouble#,+        acosDouble#,+        atanDouble#,+        sinhDouble#,+        coshDouble#,+        tanhDouble#,+        asinhDouble#,+        acoshDouble#,+        atanhDouble#,+        (**##),+        decodeDouble_2Int#,+        decodeDouble_Int64#,+        castDoubleToWord64#,+        castWord64ToDouble#,+        +{- * Float#-}+{-|Operations on single-precision (32-bit) floating-point numbers.-}+        Float#,+        gtFloat#,+        geFloat#,+        eqFloat#,+        neFloat#,+        ltFloat#,+        leFloat#,+        minFloat#,+        maxFloat#,+        plusFloat#,+        minusFloat#,+        timesFloat#,+        divideFloat#,+        negateFloat#,+        fabsFloat#,+        float2Int#,+        expFloat#,+        expm1Float#,+        logFloat#,+        log1pFloat#,+        sqrtFloat#,+        sinFloat#,+        cosFloat#,+        tanFloat#,+        asinFloat#,+        acosFloat#,+        atanFloat#,+        sinhFloat#,+        coshFloat#,+        tanhFloat#,+        asinhFloat#,+        acoshFloat#,+        atanhFloat#,+        powerFloat#,+        float2Double#,+        decodeFloat_Int#,+        castFloatToWord32#,+        castWord32ToFloat#,+        +{- * Fused multiply-add operations-}+{-| #fma#++    The fused multiply-add primops 'fmaddFloat#' and 'fmaddDouble#'+    implement the operation++    \[+    \lambda\ x\ y\ z \rightarrow x * y + z+    \]++    with a single floating-point rounding operation at the end, as opposed to+    rounding twice (which can accumulate rounding errors).++    These primops can be compiled directly to a single machine instruction on+    architectures that support them. Currently, these are:++      1. x86 with CPUs that support the FMA3 extended instruction set (which+         includes most processors since 2013).+      2. PowerPC.+      3. AArch64.++    This requires users pass the '-mfma' flag to GHC. Otherwise, the primop+    is implemented by falling back to the C standard library, which might+    perform software emulation (this may yield results that are not IEEE+    compliant on some platforms).++    The additional operations 'fmsubFloat#'/'fmsubDouble#',+    'fnmaddFloat#'/'fnmaddDouble#' and 'fnmsubFloat#'/'fnmsubDouble#' provide+    variants on 'fmaddFloat#'/'fmaddDouble#' in which some signs are changed:++    \[+    \begin{aligned}+    \mathrm{fmadd}\ x\ y\ z &= \phantom{+} x * y + z \\[8pt]+    \mathrm{fmsub}\ x\ y\ z &= \phantom{+} x * y - z \\[8pt]+    \mathrm{fnmadd}\ x\ y\ z &= - x * y + z \\[8pt]+    \mathrm{fnmsub}\ x\ y\ z &= - x * y - z+    \end{aligned}+    \]++    -}+        fmaddFloat#,+        fmsubFloat#,+        fnmaddFloat#,+        fnmsubFloat#,+        fmaddDouble#,+        fmsubDouble#,+        fnmaddDouble#,+        fnmsubDouble#,+        +{- * Arrays-}+{-|Operations on 'Array#'.-}+        Array#,+        MutableArray#,+        newArray#,+        readArray#,+        writeArray#,+        sizeofArray#,+        sizeofMutableArray#,+        indexArray#,+        unsafeFreezeArray#,+        unsafeThawArray#,+        copyArray#,+        copyMutableArray#,+        cloneArray#,+        cloneMutableArray#,+        freezeArray#,+        thawArray#,+        casArray#,+        +{- * Small Arrays-}+{-|Operations on 'SmallArray#'. A 'SmallArray#' works+         just like an 'Array#', but with different space use and+         performance characteristics (that are often useful with small+         arrays). The 'SmallArray#' and 'SmallMutableArray#'+         lack a `card table'. The purpose of a card table is to avoid+         having to scan every element of the array on each GC by+         keeping track of which elements have changed since the last GC+         and only scanning those that have changed. So the consequence+         of there being no card table is that the representation is+         somewhat smaller and the writes are somewhat faster (because+         the card table does not need to be updated). The disadvantage+         of course is that for a 'SmallMutableArray#' the whole+         array has to be scanned on each GC. Thus it is best suited for+         use cases where the mutable array is not long lived, e.g.+         where a mutable array is initialised quickly and then frozen+         to become an immutable 'SmallArray#'.+        -}+        SmallArray#,+        SmallMutableArray#,+        newSmallArray#,+        shrinkSmallMutableArray#,+        readSmallArray#,+        writeSmallArray#,+        sizeofSmallArray#,+        sizeofSmallMutableArray#,+        getSizeofSmallMutableArray#,+        indexSmallArray#,+        unsafeFreezeSmallArray#,+        unsafeThawSmallArray#,+        copySmallArray#,+        copySmallMutableArray#,+        cloneSmallArray#,+        cloneSmallMutableArray#,+        freezeSmallArray#,+        thawSmallArray#,+        casSmallArray#,+        +{- * Byte Arrays-}+{-|A 'ByteArray#' is a region of+         raw memory in the garbage-collected heap, which is not+         scanned for pointers.+         There are three sets of operations for accessing byte array contents:+         index for reading from immutable byte arrays, and read/write+         for mutable byte arrays.  Each set contains operations for a+         range of useful primitive data types.  Each operation takes+         an offset measured in terms of the size of the primitive type+         being read or written.++         -}+        ByteArray#,+        MutableByteArray#,+        newByteArray#,+        newPinnedByteArray#,+        newAlignedPinnedByteArray#,+        isMutableByteArrayPinned#,+        isByteArrayPinned#,+        isByteArrayWeaklyPinned#,+        isMutableByteArrayWeaklyPinned#,+        byteArrayContents#,+        mutableByteArrayContents#,+        shrinkMutableByteArray#,+        resizeMutableByteArray#,+        unsafeFreezeByteArray#,+        unsafeThawByteArray#,+        sizeofByteArray#,+        sizeofMutableByteArray#,+        getSizeofMutableByteArray#,+        indexCharArray#,+        indexWideCharArray#,+        indexIntArray#,+        indexWordArray#,+        indexAddrArray#,+        indexFloatArray#,+        indexDoubleArray#,+        indexStablePtrArray#,+        indexInt8Array#,+        indexWord8Array#,+        indexInt16Array#,+        indexWord16Array#,+        indexInt32Array#,+        indexWord32Array#,+        indexInt64Array#,+        indexWord64Array#,+        indexWord8ArrayAsChar#,+        indexWord8ArrayAsWideChar#,+        indexWord8ArrayAsInt#,+        indexWord8ArrayAsWord#,+        indexWord8ArrayAsAddr#,+        indexWord8ArrayAsFloat#,+        indexWord8ArrayAsDouble#,+        indexWord8ArrayAsStablePtr#,+        indexWord8ArrayAsInt16#,+        indexWord8ArrayAsWord16#,+        indexWord8ArrayAsInt32#,+        indexWord8ArrayAsWord32#,+        indexWord8ArrayAsInt64#,+        indexWord8ArrayAsWord64#,+        readCharArray#,+        readWideCharArray#,+        readIntArray#,+        readWordArray#,+        readAddrArray#,+        readFloatArray#,+        readDoubleArray#,+        readStablePtrArray#,+        readInt8Array#,+        readWord8Array#,+        readInt16Array#,+        readWord16Array#,+        readInt32Array#,+        readWord32Array#,+        readInt64Array#,+        readWord64Array#,+        readWord8ArrayAsChar#,+        readWord8ArrayAsWideChar#,+        readWord8ArrayAsInt#,+        readWord8ArrayAsWord#,+        readWord8ArrayAsAddr#,+        readWord8ArrayAsFloat#,+        readWord8ArrayAsDouble#,+        readWord8ArrayAsStablePtr#,+        readWord8ArrayAsInt16#,+        readWord8ArrayAsWord16#,+        readWord8ArrayAsInt32#,+        readWord8ArrayAsWord32#,+        readWord8ArrayAsInt64#,+        readWord8ArrayAsWord64#,+        writeCharArray#,+        writeWideCharArray#,+        writeIntArray#,+        writeWordArray#,+        writeAddrArray#,+        writeFloatArray#,+        writeDoubleArray#,+        writeStablePtrArray#,+        writeInt8Array#,+        writeWord8Array#,+        writeInt16Array#,+        writeWord16Array#,+        writeInt32Array#,+        writeWord32Array#,+        writeInt64Array#,+        writeWord64Array#,+        writeWord8ArrayAsChar#,+        writeWord8ArrayAsWideChar#,+        writeWord8ArrayAsInt#,+        writeWord8ArrayAsWord#,+        writeWord8ArrayAsAddr#,+        writeWord8ArrayAsFloat#,+        writeWord8ArrayAsDouble#,+        writeWord8ArrayAsStablePtr#,+        writeWord8ArrayAsInt16#,+        writeWord8ArrayAsWord16#,+        writeWord8ArrayAsInt32#,+        writeWord8ArrayAsWord32#,+        writeWord8ArrayAsInt64#,+        writeWord8ArrayAsWord64#,+        compareByteArrays#,+        copyByteArray#,+        copyMutableByteArray#,+        copyMutableByteArrayNonOverlapping#,+        copyByteArrayToAddr#,+        copyMutableByteArrayToAddr#,+        copyAddrToByteArray#,+        copyAddrToAddr#,+        copyAddrToAddrNonOverlapping#,+        setByteArray#,+        setAddrRange#,+        atomicReadIntArray#,+        atomicWriteIntArray#,+        casIntArray#,+        casInt8Array#,+        casInt16Array#,+        casInt32Array#,+        casInt64Array#,+        fetchAddIntArray#,+        fetchSubIntArray#,+        fetchAndIntArray#,+        fetchNandIntArray#,+        fetchOrIntArray#,+        fetchXorIntArray#,+        +{- * Addr#-}+{-|-}+        Addr#,+        nullAddr#,+        plusAddr#,+        minusAddr#,+        remAddr#,+        addr2Int#,+        int2Addr#,+        gtAddr#,+        geAddr#,+        eqAddr#,+        neAddr#,+        ltAddr#,+        leAddr#,+        indexCharOffAddr#,+        indexWideCharOffAddr#,+        indexIntOffAddr#,+        indexWordOffAddr#,+        indexAddrOffAddr#,+        indexFloatOffAddr#,+        indexDoubleOffAddr#,+        indexStablePtrOffAddr#,+        indexInt8OffAddr#,+        indexWord8OffAddr#,+        indexInt16OffAddr#,+        indexWord16OffAddr#,+        indexInt32OffAddr#,+        indexWord32OffAddr#,+        indexInt64OffAddr#,+        indexWord64OffAddr#,+        indexWord8OffAddrAsChar#,+        indexWord8OffAddrAsWideChar#,+        indexWord8OffAddrAsInt#,+        indexWord8OffAddrAsWord#,+        indexWord8OffAddrAsAddr#,+        indexWord8OffAddrAsFloat#,+        indexWord8OffAddrAsDouble#,+        indexWord8OffAddrAsStablePtr#,+        indexWord8OffAddrAsInt16#,+        indexWord8OffAddrAsWord16#,+        indexWord8OffAddrAsInt32#,+        indexWord8OffAddrAsWord32#,+        indexWord8OffAddrAsInt64#,+        indexWord8OffAddrAsWord64#,+        readCharOffAddr#,+        readWideCharOffAddr#,+        readIntOffAddr#,+        readWordOffAddr#,+        readAddrOffAddr#,+        readFloatOffAddr#,+        readDoubleOffAddr#,+        readStablePtrOffAddr#,+        readInt8OffAddr#,+        readWord8OffAddr#,+        readInt16OffAddr#,+        readWord16OffAddr#,+        readInt32OffAddr#,+        readWord32OffAddr#,+        readInt64OffAddr#,+        readWord64OffAddr#,+        readWord8OffAddrAsChar#,+        readWord8OffAddrAsWideChar#,+        readWord8OffAddrAsInt#,+        readWord8OffAddrAsWord#,+        readWord8OffAddrAsAddr#,+        readWord8OffAddrAsFloat#,+        readWord8OffAddrAsDouble#,+        readWord8OffAddrAsStablePtr#,+        readWord8OffAddrAsInt16#,+        readWord8OffAddrAsWord16#,+        readWord8OffAddrAsInt32#,+        readWord8OffAddrAsWord32#,+        readWord8OffAddrAsInt64#,+        readWord8OffAddrAsWord64#,+        writeCharOffAddr#,+        writeWideCharOffAddr#,+        writeIntOffAddr#,+        writeWordOffAddr#,+        writeAddrOffAddr#,+        writeFloatOffAddr#,+        writeDoubleOffAddr#,+        writeStablePtrOffAddr#,+        writeInt8OffAddr#,+        writeWord8OffAddr#,+        writeInt16OffAddr#,+        writeWord16OffAddr#,+        writeInt32OffAddr#,+        writeWord32OffAddr#,+        writeInt64OffAddr#,+        writeWord64OffAddr#,+        writeWord8OffAddrAsChar#,+        writeWord8OffAddrAsWideChar#,+        writeWord8OffAddrAsInt#,+        writeWord8OffAddrAsWord#,+        writeWord8OffAddrAsAddr#,+        writeWord8OffAddrAsFloat#,+        writeWord8OffAddrAsDouble#,+        writeWord8OffAddrAsStablePtr#,+        writeWord8OffAddrAsInt16#,+        writeWord8OffAddrAsWord16#,+        writeWord8OffAddrAsInt32#,+        writeWord8OffAddrAsWord32#,+        writeWord8OffAddrAsInt64#,+        writeWord8OffAddrAsWord64#,+        atomicExchangeAddrAddr#,+        atomicExchangeWordAddr#,+        atomicCasAddrAddr#,+        atomicCasWordAddr#,+        atomicCasWord8Addr#,+        atomicCasWord16Addr#,+        atomicCasWord32Addr#,+        atomicCasWord64Addr#,+        fetchAddWordAddr#,+        fetchSubWordAddr#,+        fetchAndWordAddr#,+        fetchNandWordAddr#,+        fetchOrWordAddr#,+        fetchXorWordAddr#,+        atomicReadWordAddr#,+        atomicWriteWordAddr#,+        +{- * Mutable variables-}+{-|Operations on MutVar\#s.-}+        MutVar#,+        newMutVar#,+        readMutVar#,+        writeMutVar#,+        atomicSwapMutVar#,+        atomicModifyMutVar2#,+        atomicModifyMutVar_#,+        casMutVar#,+        +{- * Exceptions-}+{-|-}+        catch#,+        raise#,+        raiseUnderflow#,+        raiseOverflow#,+        raiseDivZero#,+        raiseIO#,+        maskAsyncExceptions#,+        maskUninterruptible#,+        unmaskAsyncExceptions#,+        getMaskingState#,+        +{- * Continuations-}+{-| #continuations#++    These operations provide access to first-class delimited continuations,+    which allow a computation to access and manipulate portions of its+    /current continuation/. Operationally, they are implemented by direct+    manipulation of the RTS call stack, which may provide significant+    performance gains relative to manual continuation-passing style (CPS) for+    some programs.++    Intuitively, the delimited control operators 'prompt#' and+    'control0#' can be understood by analogy to 'catch#' and 'raiseIO#',+    respectively:++      * Like 'catch#', 'prompt#' does not do anything on its own, it+        just /delimits/ a subcomputation (the source of the name "delimited+        continuations").++      * Like 'raiseIO#', 'control0#' aborts to the nearest enclosing+        'prompt#' before resuming execution.++    However, /unlike/ 'raiseIO#', 'control0#' does /not/ discard+    the aborted computation: instead, it /captures/ it in a form that allows+    it to be resumed later. In other words, 'control0#' does not+    irreversibly abort the local computation before returning to the enclosing+    'prompt#', it merely suspends it. All local context of the suspended+    computation is packaged up and returned as an ordinary function that can be+    invoked at a later point in time to /continue/ execution, which is why+    the suspended computation is known as a /first-class continuation/.++    In GHC, every continuation prompt is associated with exactly one+    'PromptTag#'. Prompt tags are unique, opaque values created by+    'newPromptTag#' that may only be compared for equality. Both 'prompt#'+    and 'control0#' accept a 'PromptTag#' argument, and 'control0#'+    captures the continuation up to the nearest enclosing use of 'prompt#'+    /with the same tag/. This allows a program to control exactly which+    prompt it will abort to by using different tags, similar to how a program+    can control which 'catch' it will abort to by throwing different types+    of exceptions. Additionally, 'PromptTag#' accepts a single type parameter,+    which is used to relate the expected result type at the point of the+    'prompt#' to the type of the continuation produced by 'control0#'.++    == The gory details++    The high-level explanation provided above should hopefully provide some+    intuition for what these operations do, but it is not very precise; this+    section provides a more thorough explanation.++    The 'prompt#' operation morally has the following type:++@+'prompt#' :: 'PromptTag#' a -> IO a -> IO a+@++    If a computation @/m/@ never calls 'control0#', then+    @'prompt#' /tag/ /m/@ is equivalent to just @/m/@, i.e. the 'prompt#' is+    a no-op. This implies the following law:++    \[+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ x) \equiv \mathtt{pure}\ x+    \]++    The 'control0#' operation morally has the following type:++@+'control0#' :: 'PromptTag#' a -> ((IO b -> IO a) -> IO a) -> IO b+@++    @'control0#' /tag/ /f/@ captures the current continuation up to the nearest+    enclosing @'prompt#' /tag/@ and resumes execution from the point of the call+    to 'prompt#', passing the captured continuation to @/f/@. To make that+    somewhat more precise, we can say 'control0#' obeys the following law:++    \[+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{control0\#}\ tag\ f \mathbin{\mathtt{>>=}} k)+      \equiv f\ (\lambda\ m \rightarrow m \mathbin{\mathtt{>>=}} k)+    \]++    However, this law does not fully describe the behavior of 'control0#',+    as it does not account for situations where 'control0#' does not appear+    immediately inside 'prompt#'. Capturing the semantics more precisely+    requires some additional notational machinery; a common approach is to+    use [reduction semantics](https://en.wikipedia.org/wiki/Operational_semantics#Reduction_semantics).+    Assuming an appropriate definition of evaluation contexts \(E\), the+    semantics of 'prompt#' and 'control0#' can be given as follows:++    \[+    \begin{aligned}+    E[\mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ v)]+      &\longrightarrow E[\mathtt{pure}\ v] \\[8pt]+    E_1[\mathtt{prompt\#}\ \mathit{tag}\ E_2[\mathtt{control0\#}\ tag\ f]]+      &\longrightarrow E_1[f\ (\lambda\ m \rightarrow E_2[m])] \\[-2pt]+      \mathrm{where}\;\: \mathtt{prompt\#}\ \mathit{tag} &\not\in E_2+    \end{aligned}+    \]++    A full treatment of the semantics and metatheory of delimited control is+    well outside the scope of this documentation, but a good, thorough+    overview (in Haskell) is provided in [A Monadic Framework for Delimited+    Continuations](https://legacy.cs.indiana.edu/~dyb/pubs/monadicDC.pdf) by+    Dybvig et al.++    == Safety and invariants++    Correct uses of 'control0#' must obey the following restrictions:++    1. The behavior of 'control0#' is only well-defined within a /strict+       'State#' thread/, such as those associated with @IO@ and strict @ST@+       computations.++    2. Furthermore, 'control0#' may only be called within the dynamic extent+       of a 'prompt#' with a matching tag somewhere in the /current/ strict+       'State#' thread. Effectively, this means that a matching prompt must+       exist somewhere, and the captured continuation must /not/ contain any+       uses of @unsafePerformIO@, @runST@, @unsafeInterleaveIO@, etc. For+       example, the following program is ill-defined:++        @+        'prompt#' /tag/ $+          evaluate (unsafePerformIO $ 'control0#' /tag/ /f/)+        @++        In this example, the use of 'prompt#' appears in a different 'State#'+        thread from the use of 'control0#', so there is no valid prompt in+        scope to capture up to.++    3. Finally, 'control0#' may not be used within 'State#' threads associated+       with an STM transaction (i.e. those introduced by 'atomically#').++    If the runtime is able to detect that any of these invariants have been+    violated in a way that would compromise internal invariants of the runtime,+    'control0#' will fail by raising an exception. However, such violations+    are only detected on a best-effort basis, as the bookkeeping necessary for+    detecting /all/ illegal uses of 'control0#' would have significant overhead.+    Therefore, although the operations are "safe" from the runtime's point of+    view (e.g. they will not compromise memory safety or clobber internal runtime+    state), it is still ultimately the programmer's responsibility to ensure+    these invariants hold to guarantee predictable program behavior.++    In a similar vein, since each captured continuation includes the full local+    context of the suspended computation, it can safely be resumed arbitrarily+    many times without violating any invariants of the runtime system. However,+    use of these operations in an arbitrary 'IO' computation may be unsafe for+    other reasons, as most 'IO' code is not written with reentrancy in mind. For+    example, a computation suspended in the middle of reading a file will likely+    finish reading it when it is resumed; further attempts to resume from the+    same place would then fail because the file handle was already closed.++    In other words, although the RTS ensures that a computation's control state+    and local variables are properly restored for each distinct resumption of+    a continuation, it makes no attempt to duplicate any local state the+    computation may have been using (and could not possibly do so in general).+    Furthermore, it provides no mechanism for an arbitrary computation to+    protect itself against unwanted reentrancy (i.e. there is no analogue to+    Scheme's @dynamic-wind@). For those reasons, manipulating the continuation+    is only safe if the caller can be certain that doing so will not violate any+    expectations or invariants of the enclosing computation. -}+        PromptTag#,+        newPromptTag#,+        prompt#,+        control0#,+        +{- * STM-accessible Mutable Variables-}+{-|-}+        TVar#,+        atomically#,+        retry#,+        catchRetry#,+        catchSTM#,+        newTVar#,+        readTVar#,+        readTVarIO#,+        writeTVar#,+        +{- * Synchronized Mutable Variables-}+{-|Operations on 'MVar#'s. -}+        MVar#,+        newMVar#,+        takeMVar#,+        tryTakeMVar#,+        putMVar#,+        tryPutMVar#,+        readMVar#,+        tryReadMVar#,+        isEmptyMVar#,+        +{- * Delay/wait operations-}+{-|-}+        delay#,+        waitRead#,+        waitWrite#,+        +{- * Concurrency primitives-}+{-|-}+        State#,+        RealWorld,+        ThreadId#,+        fork#,+        forkOn#,+        killThread#,+        yield#,+        myThreadId#,+        labelThread#,+        isCurrentThreadBound#,+        noDuplicate#,+        threadLabel#,+        threadStatus#,+        listThreads#,+        +{- * Weak pointers-}+{-|-}+        Weak#,+        mkWeak#,+        mkWeakNoFinalizer#,+        addCFinalizerToWeak#,+        deRefWeak#,+        finalizeWeak#,+        touch#,+        +{- * Stable pointers and names-}+{-|-}+        StablePtr#,+        StableName#,+        makeStablePtr#,+        deRefStablePtr#,+        eqStablePtr#,+        makeStableName#,+        stableNameToInt#,+        +{- * Compact normal form-}+{-|Primitives for working with compact regions. The @ghc-compact@+         library and the @compact@ library demonstrate how to use these+         primitives. The documentation below draws a distinction between+         a CNF and a compact block. A CNF contains one or more compact+         blocks. The source file @rts\/sm\/CNF.c@+         diagrams this relationship. When discussing a compact+         block, an additional distinction is drawn between capacity and+         utilized bytes. The capacity is the maximum number of bytes that+         the compact block can hold. The utilized bytes is the number of+         bytes that are actually used by the compact block.+        -}+        Compact#,+        compactNew#,+        compactResize#,+        compactContains#,+        compactContainsAny#,+        compactGetFirstBlock#,+        compactGetNextBlock#,+        compactAllocateBlock#,+        compactFixupPointers#,+        compactAdd#,+        compactAddWithSharing#,+        compactSize#,+        +{- * Unsafe pointer equality-}+{-|-}+        reallyUnsafePtrEquality#,+        +{- * Parallelism-}+{-|-}+        par#,+        spark#,+        getSpark#,+        numSparks#,+        +{- * Controlling object lifetime-}+{-|Ensuring that objects don't die a premature death.-}+        keepAlive#,+        +{- * Tag to enum stuff-}+{-|Convert back and forth between values of enumerated types+        and small integers.-}+        dataToTagSmall#,+        dataToTagLarge#,+        tagToEnum#,+        +{- * Bytecode operations-}+{-|Support for manipulating bytecode objects used by the interpreter and+        linker.++        Bytecode objects are heap objects which represent top-level bindings and+        contain a list of instructions and data needed by these instructions.-}+        BCO,+        addrToAny#,+        anyToAddr#,+        mkApUpd0#,+        newBCO#,+        unpackClosure#,+        closureSize#,+        getApStackVal#,+        +{- * Misc-}+{-|These aren't nearly as wired in as Etc...-}+        getCCSOf#,+        getCurrentCCS#,+        clearCCS#,+        +{- * Annotating call stacks-}+{-|-}+        annotateStack#,+        +{- * Info Table Origin-}+{-|-}+        whereFrom#,+        +{- * Etc-}+{-|Miscellaneous built-ins-}+        FUN,+        realWorld#,+        void#,+        Proxy#,+        proxy#,+        seq,+        traceEvent#,+        traceBinaryEvent#,+        traceMarker#,+        setThreadAllocationCounter#,+        setOtherThreadAllocationCounter#,+        StackSnapshot#,+        +{- * Safe coercions-}+{-|-}+        coerce,+        +{- * SIMD Vectors-}+{-|Operations on SIMD vectors.-}+        Int8X16#,+        Int16X8#,+        Int32X4#,+        Int64X2#,+        Int8X32#,+        Int16X16#,+        Int32X8#,+        Int64X4#,+        Int8X64#,+        Int16X32#,+        Int32X16#,+        Int64X8#,+        Word8X16#,+        Word16X8#,+        Word32X4#,+        Word64X2#,+        Word8X32#,+        Word16X16#,+        Word32X8#,+        Word64X4#,+        Word8X64#,+        Word16X32#,+        Word32X16#,+        Word64X8#,+        FloatX4#,+        DoubleX2#,+        FloatX8#,+        DoubleX4#,+        FloatX16#,+        DoubleX8#,+        broadcastInt8X16#,+        broadcastInt16X8#,+        broadcastInt32X4#,+        broadcastInt64X2#,+        broadcastInt8X32#,+        broadcastInt16X16#,+        broadcastInt32X8#,+        broadcastInt64X4#,+        broadcastInt8X64#,+        broadcastInt16X32#,+        broadcastInt32X16#,+        broadcastInt64X8#,+        broadcastWord8X16#,+        broadcastWord16X8#,+        broadcastWord32X4#,+        broadcastWord64X2#,+        broadcastWord8X32#,+        broadcastWord16X16#,+        broadcastWord32X8#,+        broadcastWord64X4#,+        broadcastWord8X64#,+        broadcastWord16X32#,+        broadcastWord32X16#,+        broadcastWord64X8#,+        broadcastFloatX4#,+        broadcastDoubleX2#,+        broadcastFloatX8#,+        broadcastDoubleX4#,+        broadcastFloatX16#,+        broadcastDoubleX8#,+        packInt8X16#,+        packInt16X8#,+        packInt32X4#,+        packInt64X2#,+        packInt8X32#,+        packInt16X16#,+        packInt32X8#,+        packInt64X4#,+        packInt8X64#,+        packInt16X32#,+        packInt32X16#,+        packInt64X8#,+        packWord8X16#,+        packWord16X8#,+        packWord32X4#,+        packWord64X2#,+        packWord8X32#,+        packWord16X16#,+        packWord32X8#,+        packWord64X4#,+        packWord8X64#,+        packWord16X32#,+        packWord32X16#,+        packWord64X8#,+        packFloatX4#,+        packDoubleX2#,+        packFloatX8#,+        packDoubleX4#,+        packFloatX16#,+        packDoubleX8#,+        unpackInt8X16#,+        unpackInt16X8#,+        unpackInt32X4#,+        unpackInt64X2#,+        unpackInt8X32#,+        unpackInt16X16#,+        unpackInt32X8#,+        unpackInt64X4#,+        unpackInt8X64#,+        unpackInt16X32#,+        unpackInt32X16#,+        unpackInt64X8#,+        unpackWord8X16#,+        unpackWord16X8#,+        unpackWord32X4#,+        unpackWord64X2#,+        unpackWord8X32#,+        unpackWord16X16#,+        unpackWord32X8#,+        unpackWord64X4#,+        unpackWord8X64#,+        unpackWord16X32#,+        unpackWord32X16#,+        unpackWord64X8#,+        unpackFloatX4#,+        unpackDoubleX2#,+        unpackFloatX8#,+        unpackDoubleX4#,+        unpackFloatX16#,+        unpackDoubleX8#,+        insertInt8X16#,+        insertInt16X8#,+        insertInt32X4#,+        insertInt64X2#,+        insertInt8X32#,+        insertInt16X16#,+        insertInt32X8#,+        insertInt64X4#,+        insertInt8X64#,+        insertInt16X32#,+        insertInt32X16#,+        insertInt64X8#,+        insertWord8X16#,+        insertWord16X8#,+        insertWord32X4#,+        insertWord64X2#,+        insertWord8X32#,+        insertWord16X16#,+        insertWord32X8#,+        insertWord64X4#,+        insertWord8X64#,+        insertWord16X32#,+        insertWord32X16#,+        insertWord64X8#,+        insertFloatX4#,+        insertDoubleX2#,+        insertFloatX8#,+        insertDoubleX4#,+        insertFloatX16#,+        insertDoubleX8#,+        plusInt8X16#,+        plusInt16X8#,+        plusInt32X4#,+        plusInt64X2#,+        plusInt8X32#,+        plusInt16X16#,+        plusInt32X8#,+        plusInt64X4#,+        plusInt8X64#,+        plusInt16X32#,+        plusInt32X16#,+        plusInt64X8#,+        plusWord8X16#,+        plusWord16X8#,+        plusWord32X4#,+        plusWord64X2#,+        plusWord8X32#,+        plusWord16X16#,+        plusWord32X8#,+        plusWord64X4#,+        plusWord8X64#,+        plusWord16X32#,+        plusWord32X16#,+        plusWord64X8#,+        plusFloatX4#,+        plusDoubleX2#,+        plusFloatX8#,+        plusDoubleX4#,+        plusFloatX16#,+        plusDoubleX8#,+        minusInt8X16#,+        minusInt16X8#,+        minusInt32X4#,+        minusInt64X2#,+        minusInt8X32#,+        minusInt16X16#,+        minusInt32X8#,+        minusInt64X4#,+        minusInt8X64#,+        minusInt16X32#,+        minusInt32X16#,+        minusInt64X8#,+        minusWord8X16#,+        minusWord16X8#,+        minusWord32X4#,+        minusWord64X2#,+        minusWord8X32#,+        minusWord16X16#,+        minusWord32X8#,+        minusWord64X4#,+        minusWord8X64#,+        minusWord16X32#,+        minusWord32X16#,+        minusWord64X8#,+        minusFloatX4#,+        minusDoubleX2#,+        minusFloatX8#,+        minusDoubleX4#,+        minusFloatX16#,+        minusDoubleX8#,+        timesInt8X16#,+        timesInt16X8#,+        timesInt32X4#,+        timesInt64X2#,+        timesInt8X32#,+        timesInt16X16#,+        timesInt32X8#,+        timesInt64X4#,+        timesInt8X64#,+        timesInt16X32#,+        timesInt32X16#,+        timesInt64X8#,+        timesWord8X16#,+        timesWord16X8#,+        timesWord32X4#,+        timesWord64X2#,+        timesWord8X32#,+        timesWord16X16#,+        timesWord32X8#,+        timesWord64X4#,+        timesWord8X64#,+        timesWord16X32#,+        timesWord32X16#,+        timesWord64X8#,+        timesFloatX4#,+        timesDoubleX2#,+        timesFloatX8#,+        timesDoubleX4#,+        timesFloatX16#,+        timesDoubleX8#,+        divideFloatX4#,+        divideDoubleX2#,+        divideFloatX8#,+        divideDoubleX4#,+        divideFloatX16#,+        divideDoubleX8#,+        quotInt8X16#,+        quotInt16X8#,+        quotInt32X4#,+        quotInt64X2#,+        quotInt8X32#,+        quotInt16X16#,+        quotInt32X8#,+        quotInt64X4#,+        quotInt8X64#,+        quotInt16X32#,+        quotInt32X16#,+        quotInt64X8#,+        quotWord8X16#,+        quotWord16X8#,+        quotWord32X4#,+        quotWord64X2#,+        quotWord8X32#,+        quotWord16X16#,+        quotWord32X8#,+        quotWord64X4#,+        quotWord8X64#,+        quotWord16X32#,+        quotWord32X16#,+        quotWord64X8#,+        remInt8X16#,+        remInt16X8#,+        remInt32X4#,+        remInt64X2#,+        remInt8X32#,+        remInt16X16#,+        remInt32X8#,+        remInt64X4#,+        remInt8X64#,+        remInt16X32#,+        remInt32X16#,+        remInt64X8#,+        remWord8X16#,+        remWord16X8#,+        remWord32X4#,+        remWord64X2#,+        remWord8X32#,+        remWord16X16#,+        remWord32X8#,+        remWord64X4#,+        remWord8X64#,+        remWord16X32#,+        remWord32X16#,+        remWord64X8#,+        negateInt8X16#,+        negateInt16X8#,+        negateInt32X4#,+        negateInt64X2#,+        negateInt8X32#,+        negateInt16X16#,+        negateInt32X8#,+        negateInt64X4#,+        negateInt8X64#,+        negateInt16X32#,+        negateInt32X16#,+        negateInt64X8#,+        negateFloatX4#,+        negateDoubleX2#,+        negateFloatX8#,+        negateDoubleX4#,+        negateFloatX16#,+        negateDoubleX8#,+        indexInt8X16Array#,+        indexInt16X8Array#,+        indexInt32X4Array#,+        indexInt64X2Array#,+        indexInt8X32Array#,+        indexInt16X16Array#,+        indexInt32X8Array#,+        indexInt64X4Array#,+        indexInt8X64Array#,+        indexInt16X32Array#,+        indexInt32X16Array#,+        indexInt64X8Array#,+        indexWord8X16Array#,+        indexWord16X8Array#,+        indexWord32X4Array#,+        indexWord64X2Array#,+        indexWord8X32Array#,+        indexWord16X16Array#,+        indexWord32X8Array#,+        indexWord64X4Array#,+        indexWord8X64Array#,+        indexWord16X32Array#,+        indexWord32X16Array#,+        indexWord64X8Array#,+        indexFloatX4Array#,+        indexDoubleX2Array#,+        indexFloatX8Array#,+        indexDoubleX4Array#,+        indexFloatX16Array#,+        indexDoubleX8Array#,+        readInt8X16Array#,+        readInt16X8Array#,+        readInt32X4Array#,+        readInt64X2Array#,+        readInt8X32Array#,+        readInt16X16Array#,+        readInt32X8Array#,+        readInt64X4Array#,+        readInt8X64Array#,+        readInt16X32Array#,+        readInt32X16Array#,+        readInt64X8Array#,+        readWord8X16Array#,+        readWord16X8Array#,+        readWord32X4Array#,+        readWord64X2Array#,+        readWord8X32Array#,+        readWord16X16Array#,+        readWord32X8Array#,+        readWord64X4Array#,+        readWord8X64Array#,+        readWord16X32Array#,+        readWord32X16Array#,+        readWord64X8Array#,+        readFloatX4Array#,+        readDoubleX2Array#,+        readFloatX8Array#,+        readDoubleX4Array#,+        readFloatX16Array#,+        readDoubleX8Array#,+        writeInt8X16Array#,+        writeInt16X8Array#,+        writeInt32X4Array#,+        writeInt64X2Array#,+        writeInt8X32Array#,+        writeInt16X16Array#,+        writeInt32X8Array#,+        writeInt64X4Array#,+        writeInt8X64Array#,+        writeInt16X32Array#,+        writeInt32X16Array#,+        writeInt64X8Array#,+        writeWord8X16Array#,+        writeWord16X8Array#,+        writeWord32X4Array#,+        writeWord64X2Array#,+        writeWord8X32Array#,+        writeWord16X16Array#,+        writeWord32X8Array#,+        writeWord64X4Array#,+        writeWord8X64Array#,+        writeWord16X32Array#,+        writeWord32X16Array#,+        writeWord64X8Array#,+        writeFloatX4Array#,+        writeDoubleX2Array#,+        writeFloatX8Array#,+        writeDoubleX4Array#,+        writeFloatX16Array#,+        writeDoubleX8Array#,+        indexInt8X16OffAddr#,+        indexInt16X8OffAddr#,+        indexInt32X4OffAddr#,+        indexInt64X2OffAddr#,+        indexInt8X32OffAddr#,+        indexInt16X16OffAddr#,+        indexInt32X8OffAddr#,+        indexInt64X4OffAddr#,+        indexInt8X64OffAddr#,+        indexInt16X32OffAddr#,+        indexInt32X16OffAddr#,+        indexInt64X8OffAddr#,+        indexWord8X16OffAddr#,+        indexWord16X8OffAddr#,+        indexWord32X4OffAddr#,+        indexWord64X2OffAddr#,+        indexWord8X32OffAddr#,+        indexWord16X16OffAddr#,+        indexWord32X8OffAddr#,+        indexWord64X4OffAddr#,+        indexWord8X64OffAddr#,+        indexWord16X32OffAddr#,+        indexWord32X16OffAddr#,+        indexWord64X8OffAddr#,+        indexFloatX4OffAddr#,+        indexDoubleX2OffAddr#,+        indexFloatX8OffAddr#,+        indexDoubleX4OffAddr#,+        indexFloatX16OffAddr#,+        indexDoubleX8OffAddr#,+        readInt8X16OffAddr#,+        readInt16X8OffAddr#,+        readInt32X4OffAddr#,+        readInt64X2OffAddr#,+        readInt8X32OffAddr#,+        readInt16X16OffAddr#,+        readInt32X8OffAddr#,+        readInt64X4OffAddr#,+        readInt8X64OffAddr#,+        readInt16X32OffAddr#,+        readInt32X16OffAddr#,+        readInt64X8OffAddr#,+        readWord8X16OffAddr#,+        readWord16X8OffAddr#,+        readWord32X4OffAddr#,+        readWord64X2OffAddr#,+        readWord8X32OffAddr#,+        readWord16X16OffAddr#,+        readWord32X8OffAddr#,+        readWord64X4OffAddr#,+        readWord8X64OffAddr#,+        readWord16X32OffAddr#,+        readWord32X16OffAddr#,+        readWord64X8OffAddr#,+        readFloatX4OffAddr#,+        readDoubleX2OffAddr#,+        readFloatX8OffAddr#,+        readDoubleX4OffAddr#,+        readFloatX16OffAddr#,+        readDoubleX8OffAddr#,+        writeInt8X16OffAddr#,+        writeInt16X8OffAddr#,+        writeInt32X4OffAddr#,+        writeInt64X2OffAddr#,+        writeInt8X32OffAddr#,+        writeInt16X16OffAddr#,+        writeInt32X8OffAddr#,+        writeInt64X4OffAddr#,+        writeInt8X64OffAddr#,+        writeInt16X32OffAddr#,+        writeInt32X16OffAddr#,+        writeInt64X8OffAddr#,+        writeWord8X16OffAddr#,+        writeWord16X8OffAddr#,+        writeWord32X4OffAddr#,+        writeWord64X2OffAddr#,+        writeWord8X32OffAddr#,+        writeWord16X16OffAddr#,+        writeWord32X8OffAddr#,+        writeWord64X4OffAddr#,+        writeWord8X64OffAddr#,+        writeWord16X32OffAddr#,+        writeWord32X16OffAddr#,+        writeWord64X8OffAddr#,+        writeFloatX4OffAddr#,+        writeDoubleX2OffAddr#,+        writeFloatX8OffAddr#,+        writeDoubleX4OffAddr#,+        writeFloatX16OffAddr#,+        writeDoubleX8OffAddr#,+        indexInt8ArrayAsInt8X16#,+        indexInt16ArrayAsInt16X8#,+        indexInt32ArrayAsInt32X4#,+        indexInt64ArrayAsInt64X2#,+        indexInt8ArrayAsInt8X32#,+        indexInt16ArrayAsInt16X16#,+        indexInt32ArrayAsInt32X8#,+        indexInt64ArrayAsInt64X4#,+        indexInt8ArrayAsInt8X64#,+        indexInt16ArrayAsInt16X32#,+        indexInt32ArrayAsInt32X16#,+        indexInt64ArrayAsInt64X8#,+        indexWord8ArrayAsWord8X16#,+        indexWord16ArrayAsWord16X8#,+        indexWord32ArrayAsWord32X4#,+        indexWord64ArrayAsWord64X2#,+        indexWord8ArrayAsWord8X32#,+        indexWord16ArrayAsWord16X16#,+        indexWord32ArrayAsWord32X8#,+        indexWord64ArrayAsWord64X4#,+        indexWord8ArrayAsWord8X64#,+        indexWord16ArrayAsWord16X32#,+        indexWord32ArrayAsWord32X16#,+        indexWord64ArrayAsWord64X8#,+        indexFloatArrayAsFloatX4#,+        indexDoubleArrayAsDoubleX2#,+        indexFloatArrayAsFloatX8#,+        indexDoubleArrayAsDoubleX4#,+        indexFloatArrayAsFloatX16#,+        indexDoubleArrayAsDoubleX8#,+        readInt8ArrayAsInt8X16#,+        readInt16ArrayAsInt16X8#,+        readInt32ArrayAsInt32X4#,+        readInt64ArrayAsInt64X2#,+        readInt8ArrayAsInt8X32#,+        readInt16ArrayAsInt16X16#,+        readInt32ArrayAsInt32X8#,+        readInt64ArrayAsInt64X4#,+        readInt8ArrayAsInt8X64#,+        readInt16ArrayAsInt16X32#,+        readInt32ArrayAsInt32X16#,+        readInt64ArrayAsInt64X8#,+        readWord8ArrayAsWord8X16#,+        readWord16ArrayAsWord16X8#,+        readWord32ArrayAsWord32X4#,+        readWord64ArrayAsWord64X2#,+        readWord8ArrayAsWord8X32#,+        readWord16ArrayAsWord16X16#,+        readWord32ArrayAsWord32X8#,+        readWord64ArrayAsWord64X4#,+        readWord8ArrayAsWord8X64#,+        readWord16ArrayAsWord16X32#,+        readWord32ArrayAsWord32X16#,+        readWord64ArrayAsWord64X8#,+        readFloatArrayAsFloatX4#,+        readDoubleArrayAsDoubleX2#,+        readFloatArrayAsFloatX8#,+        readDoubleArrayAsDoubleX4#,+        readFloatArrayAsFloatX16#,+        readDoubleArrayAsDoubleX8#,+        writeInt8ArrayAsInt8X16#,+        writeInt16ArrayAsInt16X8#,+        writeInt32ArrayAsInt32X4#,+        writeInt64ArrayAsInt64X2#,+        writeInt8ArrayAsInt8X32#,+        writeInt16ArrayAsInt16X16#,+        writeInt32ArrayAsInt32X8#,+        writeInt64ArrayAsInt64X4#,+        writeInt8ArrayAsInt8X64#,+        writeInt16ArrayAsInt16X32#,+        writeInt32ArrayAsInt32X16#,+        writeInt64ArrayAsInt64X8#,+        writeWord8ArrayAsWord8X16#,+        writeWord16ArrayAsWord16X8#,+        writeWord32ArrayAsWord32X4#,+        writeWord64ArrayAsWord64X2#,+        writeWord8ArrayAsWord8X32#,+        writeWord16ArrayAsWord16X16#,+        writeWord32ArrayAsWord32X8#,+        writeWord64ArrayAsWord64X4#,+        writeWord8ArrayAsWord8X64#,+        writeWord16ArrayAsWord16X32#,+        writeWord32ArrayAsWord32X16#,+        writeWord64ArrayAsWord64X8#,+        writeFloatArrayAsFloatX4#,+        writeDoubleArrayAsDoubleX2#,+        writeFloatArrayAsFloatX8#,+        writeDoubleArrayAsDoubleX4#,+        writeFloatArrayAsFloatX16#,+        writeDoubleArrayAsDoubleX8#,+        indexInt8OffAddrAsInt8X16#,+        indexInt16OffAddrAsInt16X8#,+        indexInt32OffAddrAsInt32X4#,+        indexInt64OffAddrAsInt64X2#,+        indexInt8OffAddrAsInt8X32#,+        indexInt16OffAddrAsInt16X16#,+        indexInt32OffAddrAsInt32X8#,+        indexInt64OffAddrAsInt64X4#,+        indexInt8OffAddrAsInt8X64#,+        indexInt16OffAddrAsInt16X32#,+        indexInt32OffAddrAsInt32X16#,+        indexInt64OffAddrAsInt64X8#,+        indexWord8OffAddrAsWord8X16#,+        indexWord16OffAddrAsWord16X8#,+        indexWord32OffAddrAsWord32X4#,+        indexWord64OffAddrAsWord64X2#,+        indexWord8OffAddrAsWord8X32#,+        indexWord16OffAddrAsWord16X16#,+        indexWord32OffAddrAsWord32X8#,+        indexWord64OffAddrAsWord64X4#,+        indexWord8OffAddrAsWord8X64#,+        indexWord16OffAddrAsWord16X32#,+        indexWord32OffAddrAsWord32X16#,+        indexWord64OffAddrAsWord64X8#,+        indexFloatOffAddrAsFloatX4#,+        indexDoubleOffAddrAsDoubleX2#,+        indexFloatOffAddrAsFloatX8#,+        indexDoubleOffAddrAsDoubleX4#,+        indexFloatOffAddrAsFloatX16#,+        indexDoubleOffAddrAsDoubleX8#,+        readInt8OffAddrAsInt8X16#,+        readInt16OffAddrAsInt16X8#,+        readInt32OffAddrAsInt32X4#,+        readInt64OffAddrAsInt64X2#,+        readInt8OffAddrAsInt8X32#,+        readInt16OffAddrAsInt16X16#,+        readInt32OffAddrAsInt32X8#,+        readInt64OffAddrAsInt64X4#,+        readInt8OffAddrAsInt8X64#,+        readInt16OffAddrAsInt16X32#,+        readInt32OffAddrAsInt32X16#,+        readInt64OffAddrAsInt64X8#,+        readWord8OffAddrAsWord8X16#,+        readWord16OffAddrAsWord16X8#,+        readWord32OffAddrAsWord32X4#,+        readWord64OffAddrAsWord64X2#,+        readWord8OffAddrAsWord8X32#,+        readWord16OffAddrAsWord16X16#,+        readWord32OffAddrAsWord32X8#,+        readWord64OffAddrAsWord64X4#,+        readWord8OffAddrAsWord8X64#,+        readWord16OffAddrAsWord16X32#,+        readWord32OffAddrAsWord32X16#,+        readWord64OffAddrAsWord64X8#,+        readFloatOffAddrAsFloatX4#,+        readDoubleOffAddrAsDoubleX2#,+        readFloatOffAddrAsFloatX8#,+        readDoubleOffAddrAsDoubleX4#,+        readFloatOffAddrAsFloatX16#,+        readDoubleOffAddrAsDoubleX8#,+        writeInt8OffAddrAsInt8X16#,+        writeInt16OffAddrAsInt16X8#,+        writeInt32OffAddrAsInt32X4#,+        writeInt64OffAddrAsInt64X2#,+        writeInt8OffAddrAsInt8X32#,+        writeInt16OffAddrAsInt16X16#,+        writeInt32OffAddrAsInt32X8#,+        writeInt64OffAddrAsInt64X4#,+        writeInt8OffAddrAsInt8X64#,+        writeInt16OffAddrAsInt16X32#,+        writeInt32OffAddrAsInt32X16#,+        writeInt64OffAddrAsInt64X8#,+        writeWord8OffAddrAsWord8X16#,+        writeWord16OffAddrAsWord16X8#,+        writeWord32OffAddrAsWord32X4#,+        writeWord64OffAddrAsWord64X2#,+        writeWord8OffAddrAsWord8X32#,+        writeWord16OffAddrAsWord16X16#,+        writeWord32OffAddrAsWord32X8#,+        writeWord64OffAddrAsWord64X4#,+        writeWord8OffAddrAsWord8X64#,+        writeWord16OffAddrAsWord16X32#,+        writeWord32OffAddrAsWord32X16#,+        writeWord64OffAddrAsWord64X8#,+        writeFloatOffAddrAsFloatX4#,+        writeDoubleOffAddrAsDoubleX2#,+        writeFloatOffAddrAsFloatX8#,+        writeDoubleOffAddrAsDoubleX4#,+        writeFloatOffAddrAsFloatX16#,+        writeDoubleOffAddrAsDoubleX8#,+        fmaddFloatX4#,+        fmaddDoubleX2#,+        fmaddFloatX8#,+        fmaddDoubleX4#,+        fmaddFloatX16#,+        fmaddDoubleX8#,+        fmsubFloatX4#,+        fmsubDoubleX2#,+        fmsubFloatX8#,+        fmsubDoubleX4#,+        fmsubFloatX16#,+        fmsubDoubleX8#,+        fnmaddFloatX4#,+        fnmaddDoubleX2#,+        fnmaddFloatX8#,+        fnmaddDoubleX4#,+        fnmaddFloatX16#,+        fnmaddDoubleX8#,+        fnmsubFloatX4#,+        fnmsubDoubleX2#,+        fnmsubFloatX8#,+        fnmsubDoubleX4#,+        fnmsubFloatX16#,+        fnmsubDoubleX8#,+        shuffleInt8X16#,+        shuffleInt16X8#,+        shuffleInt32X4#,+        shuffleInt64X2#,+        shuffleInt8X32#,+        shuffleInt16X16#,+        shuffleInt32X8#,+        shuffleInt64X4#,+        shuffleInt8X64#,+        shuffleInt16X32#,+        shuffleInt32X16#,+        shuffleInt64X8#,+        shuffleWord8X16#,+        shuffleWord16X8#,+        shuffleWord32X4#,+        shuffleWord64X2#,+        shuffleWord8X32#,+        shuffleWord16X16#,+        shuffleWord32X8#,+        shuffleWord64X4#,+        shuffleWord8X64#,+        shuffleWord16X32#,+        shuffleWord32X16#,+        shuffleWord64X8#,+        shuffleFloatX4#,+        shuffleDoubleX2#,+        shuffleFloatX8#,+        shuffleDoubleX4#,+        shuffleFloatX16#,+        shuffleDoubleX8#,+        minInt8X16#,+        minInt16X8#,+        minInt32X4#,+        minInt64X2#,+        minInt8X32#,+        minInt16X16#,+        minInt32X8#,+        minInt64X4#,+        minInt8X64#,+        minInt16X32#,+        minInt32X16#,+        minInt64X8#,+        minWord8X16#,+        minWord16X8#,+        minWord32X4#,+        minWord64X2#,+        minWord8X32#,+        minWord16X16#,+        minWord32X8#,+        minWord64X4#,+        minWord8X64#,+        minWord16X32#,+        minWord32X16#,+        minWord64X8#,+        minFloatX4#,+        minDoubleX2#,+        minFloatX8#,+        minDoubleX4#,+        minFloatX16#,+        minDoubleX8#,+        maxInt8X16#,+        maxInt16X8#,+        maxInt32X4#,+        maxInt64X2#,+        maxInt8X32#,+        maxInt16X16#,+        maxInt32X8#,+        maxInt64X4#,+        maxInt8X64#,+        maxInt16X32#,+        maxInt32X16#,+        maxInt64X8#,+        maxWord8X16#,+        maxWord16X8#,+        maxWord32X4#,+        maxWord64X2#,+        maxWord8X32#,+        maxWord16X16#,+        maxWord32X8#,+        maxWord64X4#,+        maxWord8X64#,+        maxWord16X32#,+        maxWord32X16#,+        maxWord64X8#,+        maxFloatX4#,+        maxDoubleX2#,+        maxFloatX8#,+        maxDoubleX4#,+        maxFloatX16#,+        maxDoubleX8#,+        +{- * Prefetch-}+{-|Prefetch operations: Note how every prefetch operation has a name+  with the pattern prefetch*N#, where N is either 0,1,2, or 3.++  This suffix number, N, is the "locality level" of the prefetch, following the+  convention in GCC and other compilers.+  Higher locality numbers correspond to the memory being loaded in more+  levels of the cpu cache, and being retained after initial use. The naming+  convention follows the naming convention of the prefetch intrinsic found+  in the GCC and Clang C compilers.++  On the LLVM backend, prefetch*N# uses the LLVM prefetch intrinsic+  with locality level N. The code generated by LLVM is target architecture+  dependent, but should agree with the GHC NCG on x86 systems.++  On the PPC native backend, prefetch*N is a No-Op.++  On the x86 NCG, N=0 will generate prefetchNTA,+  N=1 generates prefetcht2, N=2 generates prefetcht1, and+  N=3 generates prefetcht0.++  For streaming workloads, the prefetch*0 operations are recommended.+  For workloads which do many reads or writes to a memory location in a short period of time,+  prefetch*3 operations are recommended.++  For further reading about prefetch and associated systems performance optimization,+  the instruction set and optimization manuals by Intel and other CPU vendors are+  excellent starting place.+++  The "Intel 64 and IA-32 Architectures Optimization Reference Manual" is+  especially a helpful read, even if your software is meant for other CPU+  architectures or vendor hardware. The manual can be found at+  http://www.intel.com/content/www/us/en/architecture-and-technology/64-ia-32-architectures-optimization-manual.html .++  The @prefetch*@ family of operations has the order of operations+  determined by passing around the 'State#' token.++  To get a "pure" version of these operations, use 'inlinePerformIO' which is quite safe in this context.++  It is important to note that while the prefetch operations will never change the+  answer to a pure computation, They CAN change the memory locations resident+  in a CPU cache and that may change the performance and timing characteristics+  of an application. The prefetch operations are marked as ReadWriteEffect+  to reflect that these operations have side effects with respect to the runtime+  performance characteristics of the resulting code. Additionally, if the prefetchValue+  operations did not have this attribute, GHC does a float out transformation that+  results in a let-can-float invariant violation, at least with the current design.+  -}+        prefetchByteArray3#,+        prefetchMutableByteArray3#,+        prefetchAddr3#,+        prefetchValue3#,+        prefetchByteArray2#,+        prefetchMutableByteArray2#,+        prefetchAddr2#,+        prefetchValue2#,+        prefetchByteArray1#,+        prefetchMutableByteArray1#,+        prefetchAddr1#,+        prefetchValue1#,+        prefetchByteArray0#,+        prefetchMutableByteArray0#,+        prefetchAddr0#,+        prefetchValue0#,+        +{- * RuntimeRep polymorphism in continuation-style primops-}+{-|+  Several primops provided by GHC accept continuation arguments with highly polymorphic+  arguments. For instance, consider the type of `catch#`:++    catch# :: forall (r_rep :: RuntimeRep) (r :: TYPE r_rep) w.+              (State# RealWorld -> (# State# RealWorld, r #) )+           -> (w -> State# RealWorld -> (# State# RealWorld, r #) )+           -> State# RealWorld+           -> (# State# RealWorld, r #)++  This type suggests that we could instantiate `catch#` continuation argument+  (namely, the first argument) with something like,++    f :: State# RealWorld -> (# State# RealWorld, (# Int, String, Int8# #) #)++  However, sadly the type does not capture an important limitation of the+  primop. Specifically, due to the operational behavior of `catch#` the result+  type must be representable with a single machine word. In a future GHC+  release we may improve the precision of this type to capture this limitation.++  See #21868.+  -}+) where++{-+effect = NoEffect+can_fail_warning = WarnIfEffectIsCanFail+out_of_line = False+commutable = False+code_size = {  primOpCodeSizeDefault }+work_free = {  primOpCodeSize _thisOp == 0 }+cheap = {  primOpOkForSpeculation _thisOp }+strictness = {  \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv }+fixity = Nothing++deprecated_msg = { }+div_like = False+defined_bits = Nothing+-}+default ()++data Char#++gtChar# :: Char# -> Char# -> Int#+gtChar# = gtChar#++geChar# :: Char# -> Char# -> Int#+geChar# = geChar#++eqChar# :: Char# -> Char# -> Int#+eqChar# = eqChar#++neChar# :: Char# -> Char# -> Int#+neChar# = neChar#++ltChar# :: Char# -> Char# -> Int#+ltChar# = ltChar#++leChar# :: Char# -> Char# -> Int#+leChar# = leChar#++ord# :: Char# -> Int#+ord# = ord#++data Int8#++int8ToInt# :: Int8# -> Int#+int8ToInt# = int8ToInt#++intToInt8# :: Int# -> Int8#+intToInt8# = intToInt8#++negateInt8# :: Int8# -> Int8#+negateInt8# = negateInt8#++plusInt8# :: Int8# -> Int8# -> Int8#+plusInt8# = plusInt8#++subInt8# :: Int8# -> Int8# -> Int8#+subInt8# = subInt8#++timesInt8# :: Int8# -> Int8# -> Int8#+timesInt8# = timesInt8#++quotInt8# :: Int8# -> Int8# -> Int8#+quotInt8# = quotInt8#++remInt8# :: Int8# -> Int8# -> Int8#+remInt8# = remInt8#++quotRemInt8# :: Int8# -> Int8# -> (# Int8#,Int8# #)+quotRemInt8# = quotRemInt8#++uncheckedShiftLInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftLInt8# = uncheckedShiftLInt8#++uncheckedShiftRAInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftRAInt8# = uncheckedShiftRAInt8#++uncheckedShiftRLInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftRLInt8# = uncheckedShiftRLInt8#++int8ToWord8# :: Int8# -> Word8#+int8ToWord8# = int8ToWord8#++eqInt8# :: Int8# -> Int8# -> Int#+eqInt8# = eqInt8#++geInt8# :: Int8# -> Int8# -> Int#+geInt8# = geInt8#++gtInt8# :: Int8# -> Int8# -> Int#+gtInt8# = gtInt8#++leInt8# :: Int8# -> Int8# -> Int#+leInt8# = leInt8#++ltInt8# :: Int8# -> Int8# -> Int#+ltInt8# = ltInt8#++neInt8# :: Int8# -> Int8# -> Int#+neInt8# = neInt8#++data Word8#++word8ToWord# :: Word8# -> Word#+word8ToWord# = word8ToWord#++wordToWord8# :: Word# -> Word8#+wordToWord8# = wordToWord8#++plusWord8# :: Word8# -> Word8# -> Word8#+plusWord8# = plusWord8#++subWord8# :: Word8# -> Word8# -> Word8#+subWord8# = subWord8#++timesWord8# :: Word8# -> Word8# -> Word8#+timesWord8# = timesWord8#++quotWord8# :: Word8# -> Word8# -> Word8#+quotWord8# = quotWord8#++remWord8# :: Word8# -> Word8# -> Word8#+remWord8# = remWord8#++quotRemWord8# :: Word8# -> Word8# -> (# Word8#,Word8# #)+quotRemWord8# = quotRemWord8#++andWord8# :: Word8# -> Word8# -> Word8#+andWord8# = andWord8#++orWord8# :: Word8# -> Word8# -> Word8#+orWord8# = orWord8#++xorWord8# :: Word8# -> Word8# -> Word8#+xorWord8# = xorWord8#++notWord8# :: Word8# -> Word8#+notWord8# = notWord8#++uncheckedShiftLWord8# :: Word8# -> Int# -> Word8#+uncheckedShiftLWord8# = uncheckedShiftLWord8#++uncheckedShiftRLWord8# :: Word8# -> Int# -> Word8#+uncheckedShiftRLWord8# = uncheckedShiftRLWord8#++word8ToInt8# :: Word8# -> Int8#+word8ToInt8# = word8ToInt8#++eqWord8# :: Word8# -> Word8# -> Int#+eqWord8# = eqWord8#++geWord8# :: Word8# -> Word8# -> Int#+geWord8# = geWord8#++gtWord8# :: Word8# -> Word8# -> Int#+gtWord8# = gtWord8#++leWord8# :: Word8# -> Word8# -> Int#+leWord8# = leWord8#++ltWord8# :: Word8# -> Word8# -> Int#+ltWord8# = ltWord8#++neWord8# :: Word8# -> Word8# -> Int#+neWord8# = neWord8#++data Int16#++int16ToInt# :: Int16# -> Int#+int16ToInt# = int16ToInt#++intToInt16# :: Int# -> Int16#+intToInt16# = intToInt16#++negateInt16# :: Int16# -> Int16#+negateInt16# = negateInt16#++plusInt16# :: Int16# -> Int16# -> Int16#+plusInt16# = plusInt16#++subInt16# :: Int16# -> Int16# -> Int16#+subInt16# = subInt16#++timesInt16# :: Int16# -> Int16# -> Int16#+timesInt16# = timesInt16#++quotInt16# :: Int16# -> Int16# -> Int16#+quotInt16# = quotInt16#++remInt16# :: Int16# -> Int16# -> Int16#+remInt16# = remInt16#++quotRemInt16# :: Int16# -> Int16# -> (# Int16#,Int16# #)+quotRemInt16# = quotRemInt16#++uncheckedShiftLInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftLInt16# = uncheckedShiftLInt16#++uncheckedShiftRAInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftRAInt16# = uncheckedShiftRAInt16#++uncheckedShiftRLInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftRLInt16# = uncheckedShiftRLInt16#++int16ToWord16# :: Int16# -> Word16#+int16ToWord16# = int16ToWord16#++eqInt16# :: Int16# -> Int16# -> Int#+eqInt16# = eqInt16#++geInt16# :: Int16# -> Int16# -> Int#+geInt16# = geInt16#++gtInt16# :: Int16# -> Int16# -> Int#+gtInt16# = gtInt16#++leInt16# :: Int16# -> Int16# -> Int#+leInt16# = leInt16#++ltInt16# :: Int16# -> Int16# -> Int#+ltInt16# = ltInt16#++neInt16# :: Int16# -> Int16# -> Int#+neInt16# = neInt16#++data Word16#++word16ToWord# :: Word16# -> Word#+word16ToWord# = word16ToWord#++wordToWord16# :: Word# -> Word16#+wordToWord16# = wordToWord16#++plusWord16# :: Word16# -> Word16# -> Word16#+plusWord16# = plusWord16#++subWord16# :: Word16# -> Word16# -> Word16#+subWord16# = subWord16#++timesWord16# :: Word16# -> Word16# -> Word16#+timesWord16# = timesWord16#++quotWord16# :: Word16# -> Word16# -> Word16#+quotWord16# = quotWord16#++remWord16# :: Word16# -> Word16# -> Word16#+remWord16# = remWord16#++quotRemWord16# :: Word16# -> Word16# -> (# Word16#,Word16# #)+quotRemWord16# = quotRemWord16#++andWord16# :: Word16# -> Word16# -> Word16#+andWord16# = andWord16#++orWord16# :: Word16# -> Word16# -> Word16#+orWord16# = orWord16#++xorWord16# :: Word16# -> Word16# -> Word16#+xorWord16# = xorWord16#++notWord16# :: Word16# -> Word16#+notWord16# = notWord16#++uncheckedShiftLWord16# :: Word16# -> Int# -> Word16#+uncheckedShiftLWord16# = uncheckedShiftLWord16#++uncheckedShiftRLWord16# :: Word16# -> Int# -> Word16#+uncheckedShiftRLWord16# = uncheckedShiftRLWord16#++word16ToInt16# :: Word16# -> Int16#+word16ToInt16# = word16ToInt16#++eqWord16# :: Word16# -> Word16# -> Int#+eqWord16# = eqWord16#++geWord16# :: Word16# -> Word16# -> Int#+geWord16# = geWord16#++gtWord16# :: Word16# -> Word16# -> Int#+gtWord16# = gtWord16#++leWord16# :: Word16# -> Word16# -> Int#+leWord16# = leWord16#++ltWord16# :: Word16# -> Word16# -> Int#+ltWord16# = ltWord16#++neWord16# :: Word16# -> Word16# -> Int#+neWord16# = neWord16#++data Int32#++int32ToInt# :: Int32# -> Int#+int32ToInt# = int32ToInt#++intToInt32# :: Int# -> Int32#+intToInt32# = intToInt32#++negateInt32# :: Int32# -> Int32#+negateInt32# = negateInt32#++plusInt32# :: Int32# -> Int32# -> Int32#+plusInt32# = plusInt32#++subInt32# :: Int32# -> Int32# -> Int32#+subInt32# = subInt32#++timesInt32# :: Int32# -> Int32# -> Int32#+timesInt32# = timesInt32#++quotInt32# :: Int32# -> Int32# -> Int32#+quotInt32# = quotInt32#++remInt32# :: Int32# -> Int32# -> Int32#+remInt32# = remInt32#++quotRemInt32# :: Int32# -> Int32# -> (# Int32#,Int32# #)+quotRemInt32# = quotRemInt32#++uncheckedShiftLInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftLInt32# = uncheckedShiftLInt32#++uncheckedShiftRAInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftRAInt32# = uncheckedShiftRAInt32#++uncheckedShiftRLInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftRLInt32# = uncheckedShiftRLInt32#++int32ToWord32# :: Int32# -> Word32#+int32ToWord32# = int32ToWord32#++eqInt32# :: Int32# -> Int32# -> Int#+eqInt32# = eqInt32#++geInt32# :: Int32# -> Int32# -> Int#+geInt32# = geInt32#++gtInt32# :: Int32# -> Int32# -> Int#+gtInt32# = gtInt32#++leInt32# :: Int32# -> Int32# -> Int#+leInt32# = leInt32#++ltInt32# :: Int32# -> Int32# -> Int#+ltInt32# = ltInt32#++neInt32# :: Int32# -> Int32# -> Int#+neInt32# = neInt32#++data Word32#++word32ToWord# :: Word32# -> Word#+word32ToWord# = word32ToWord#++wordToWord32# :: Word# -> Word32#+wordToWord32# = wordToWord32#++plusWord32# :: Word32# -> Word32# -> Word32#+plusWord32# = plusWord32#++subWord32# :: Word32# -> Word32# -> Word32#+subWord32# = subWord32#++timesWord32# :: Word32# -> Word32# -> Word32#+timesWord32# = timesWord32#++quotWord32# :: Word32# -> Word32# -> Word32#+quotWord32# = quotWord32#++remWord32# :: Word32# -> Word32# -> Word32#+remWord32# = remWord32#++quotRemWord32# :: Word32# -> Word32# -> (# Word32#,Word32# #)+quotRemWord32# = quotRemWord32#++andWord32# :: Word32# -> Word32# -> Word32#+andWord32# = andWord32#++orWord32# :: Word32# -> Word32# -> Word32#+orWord32# = orWord32#++xorWord32# :: Word32# -> Word32# -> Word32#+xorWord32# = xorWord32#++notWord32# :: Word32# -> Word32#+notWord32# = notWord32#++uncheckedShiftLWord32# :: Word32# -> Int# -> Word32#+uncheckedShiftLWord32# = uncheckedShiftLWord32#++uncheckedShiftRLWord32# :: Word32# -> Int# -> Word32#+uncheckedShiftRLWord32# = uncheckedShiftRLWord32#++word32ToInt32# :: Word32# -> Int32#+word32ToInt32# = word32ToInt32#++eqWord32# :: Word32# -> Word32# -> Int#+eqWord32# = eqWord32#++geWord32# :: Word32# -> Word32# -> Int#+geWord32# = geWord32#++gtWord32# :: Word32# -> Word32# -> Int#+gtWord32# = gtWord32#++leWord32# :: Word32# -> Word32# -> Int#+leWord32# = leWord32#++ltWord32# :: Word32# -> Word32# -> Int#+ltWord32# = ltWord32#++neWord32# :: Word32# -> Word32# -> Int#+neWord32# = neWord32#++data Int64#++int64ToInt# :: Int64# -> Int#+int64ToInt# = int64ToInt#++intToInt64# :: Int# -> Int64#+intToInt64# = intToInt64#++negateInt64# :: Int64# -> Int64#+negateInt64# = negateInt64#++plusInt64# :: Int64# -> Int64# -> Int64#+plusInt64# = plusInt64#++subInt64# :: Int64# -> Int64# -> Int64#+subInt64# = subInt64#++timesInt64# :: Int64# -> Int64# -> Int64#+timesInt64# = timesInt64#++quotInt64# :: Int64# -> Int64# -> Int64#+quotInt64# = quotInt64#++remInt64# :: Int64# -> Int64# -> Int64#+remInt64# = remInt64#++uncheckedIShiftL64# :: Int64# -> Int# -> Int64#+uncheckedIShiftL64# = uncheckedIShiftL64#++uncheckedIShiftRA64# :: Int64# -> Int# -> Int64#+uncheckedIShiftRA64# = uncheckedIShiftRA64#++uncheckedIShiftRL64# :: Int64# -> Int# -> Int64#+uncheckedIShiftRL64# = uncheckedIShiftRL64#++int64ToWord64# :: Int64# -> Word64#+int64ToWord64# = int64ToWord64#++eqInt64# :: Int64# -> Int64# -> Int#+eqInt64# = eqInt64#++geInt64# :: Int64# -> Int64# -> Int#+geInt64# = geInt64#++gtInt64# :: Int64# -> Int64# -> Int#+gtInt64# = gtInt64#++leInt64# :: Int64# -> Int64# -> Int#+leInt64# = leInt64#++ltInt64# :: Int64# -> Int64# -> Int#+ltInt64# = ltInt64#++neInt64# :: Int64# -> Int64# -> Int#+neInt64# = neInt64#++data Word64#++word64ToWord# :: Word64# -> Word#+word64ToWord# = word64ToWord#++wordToWord64# :: Word# -> Word64#+wordToWord64# = wordToWord64#++plusWord64# :: Word64# -> Word64# -> Word64#+plusWord64# = plusWord64#++subWord64# :: Word64# -> Word64# -> Word64#+subWord64# = subWord64#++timesWord64# :: Word64# -> Word64# -> Word64#+timesWord64# = timesWord64#++quotWord64# :: Word64# -> Word64# -> Word64#+quotWord64# = quotWord64#++remWord64# :: Word64# -> Word64# -> Word64#+remWord64# = remWord64#++and64# :: Word64# -> Word64# -> Word64#+and64# = and64#++or64# :: Word64# -> Word64# -> Word64#+or64# = or64#++xor64# :: Word64# -> Word64# -> Word64#+xor64# = xor64#++not64# :: Word64# -> Word64#+not64# = not64#++uncheckedShiftL64# :: Word64# -> Int# -> Word64#+uncheckedShiftL64# = uncheckedShiftL64#++uncheckedShiftRL64# :: Word64# -> Int# -> Word64#+uncheckedShiftRL64# = uncheckedShiftRL64#++word64ToInt64# :: Word64# -> Int64#+word64ToInt64# = word64ToInt64#++eqWord64# :: Word64# -> Word64# -> Int#+eqWord64# = eqWord64#++geWord64# :: Word64# -> Word64# -> Int#+geWord64# = geWord64#++gtWord64# :: Word64# -> Word64# -> Int#+gtWord64# = gtWord64#++leWord64# :: Word64# -> Word64# -> Int#+leWord64# = leWord64#++ltWord64# :: Word64# -> Word64# -> Int#+ltWord64# = ltWord64#++neWord64# :: Word64# -> Word64# -> Int#+neWord64# = neWord64#++data Int#++infixl 6 +#+(+#) :: Int# -> Int# -> Int#+(+#) = (+#)++infixl 6 -#+(-#) :: Int# -> Int# -> Int#+(-#) = (-#)++{-|Low word of signed integer multiply.-}+infixl 7 *#+(*#) :: Int# -> Int# -> Int#+(*#) = (*#)++{-|Return a triple (isHighNeeded,high,low) where high and low are respectively+   the high and low bits of the double-word result. isHighNeeded is a cheap way+   to test if the high word is a sign-extension of the low word (isHighNeeded =+   0#) or not (isHighNeeded = 1#).-}+timesInt2# :: Int# -> Int# -> (# Int#,Int#,Int# #)+timesInt2# = timesInt2#++{-|Return non-zero if there is any possibility that the upper word of a+    signed integer multiply might contain useful information.  Return+    zero only if you are completely sure that no overflow can occur.+    On a 32-bit platform, the recommended implementation is to do a+    32 x 32 -> 64 signed multiply, and subtract result[63:32] from+    (result[31] >>signed 31).  If this is zero, meaning that the+    upper word is merely a sign extension of the lower one, no+    overflow can occur.++    On a 64-bit platform it is not always possible to+    acquire the top 64 bits of the result.  Therefore, a recommended+    implementation is to take the absolute value of both operands, and+    return 0 iff bits[63:31] of them are zero, since that means that their+    magnitudes fit within 31 bits, so the magnitude of the product must fit+    into 62 bits.++    If in doubt, return non-zero, but do make an effort to create the+    correct answer for small args, since otherwise the performance of+    @(*) :: Integer -> Integer -> Integer@ will be poor.+   -}+mulIntMayOflo# :: Int# -> Int# -> Int#+mulIntMayOflo# = mulIntMayOflo#++{-|Rounds towards zero. The behavior is undefined if the second argument is+    zero.+   -}+quotInt# :: Int# -> Int# -> Int#+quotInt# = quotInt#++{-|Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The+    behavior is undefined if the second argument is zero.+   -}+remInt# :: Int# -> Int# -> Int#+remInt# = remInt#++{-|Rounds towards zero.-}+quotRemInt# :: Int# -> Int# -> (# Int#,Int# #)+quotRemInt# = quotRemInt#++{-|Bitwise "and".-}+andI# :: Int# -> Int# -> Int#+andI# = andI#++{-|Bitwise "or".-}+orI# :: Int# -> Int# -> Int#+orI# = orI#++{-|Bitwise "xor".-}+xorI# :: Int# -> Int# -> Int#+xorI# = xorI#++{-|Bitwise "not", also known as the binary complement.-}+notI# :: Int# -> Int#+notI# = notI#++{-|Unary negation.+    Since the negative 'Int#' range extends one further than the+    positive range, 'negateInt#' of the most negative number is an+    identity operation. This way, 'negateInt#' is always its own inverse.-}+negateInt# :: Int# -> Int#+negateInt# = negateInt#++{-|Add signed integers reporting overflow.+          First member of result is the sum truncated to an 'Int#';+          second member is zero if the true sum fits in an 'Int#',+          nonzero if overflow occurred (the sum is either too large+          or too small to fit in an 'Int#').-}+addIntC# :: Int# -> Int# -> (# Int#,Int# #)+addIntC# = addIntC#++{-|Subtract signed integers reporting overflow.+          First member of result is the difference truncated to an 'Int#';+          second member is zero if the true difference fits in an 'Int#',+          nonzero if overflow occurred (the difference is either too large+          or too small to fit in an 'Int#').-}+subIntC# :: Int# -> Int# -> (# Int#,Int# #)+subIntC# = subIntC#++infix 4 >#+(>#) :: Int# -> Int# -> Int#+(>#) = (>#)++infix 4 >=#+(>=#) :: Int# -> Int# -> Int#+(>=#) = (>=#)++infix 4 ==#+(==#) :: Int# -> Int# -> Int#+(==#) = (==#)++infix 4 /=#+(/=#) :: Int# -> Int# -> Int#+(/=#) = (/=#)++infix 4 <#+(<#) :: Int# -> Int# -> Int#+(<#) = (<#)++infix 4 <=#+(<=#) :: Int# -> Int# -> Int#+(<=#) = (<=#)++chr# :: Int# -> Char#+chr# = chr#++int2Word# :: Int# -> Word#+int2Word# = int2Word#++{-|Convert an 'Int#' to the corresponding 'Float#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'int2Float#' 1# == 1.0#@-}+int2Float# :: Int# -> Float#+int2Float# = int2Float#++{-|Convert an 'Int#' to the corresponding 'Double#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'int2Double#' 1# == 1.0##@-}+int2Double# :: Int# -> Double#+int2Double# = int2Double#++{-|Convert an 'Word#' to the corresponding 'Float#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'word2Float#' 1## == 1.0#@-}+word2Float# :: Word# -> Float#+word2Float# = word2Float#++{-|Convert an 'Word#' to the corresponding 'Double#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'word2Double#' 1## == 1.0##@-}+word2Double# :: Word# -> Double#+word2Double# = word2Double#++{-|Shift left.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedIShiftL# :: Int# -> Int# -> Int#+uncheckedIShiftL# = uncheckedIShiftL#++{-|Shift right arithmetic.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedIShiftRA# :: Int# -> Int# -> Int#+uncheckedIShiftRA# = uncheckedIShiftRA#++{-|Shift right logical.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedIShiftRL# :: Int# -> Int# -> Int#+uncheckedIShiftRL# = uncheckedIShiftRL#++data Word#++plusWord# :: Word# -> Word# -> Word#+plusWord# = plusWord#++{-|Add unsigned integers reporting overflow.+          The first element of the pair is the result.  The second element is+          the carry flag, which is nonzero on overflow. See also 'plusWord2#'.-}+addWordC# :: Word# -> Word# -> (# Word#,Int# #)+addWordC# = addWordC#++{-|Subtract unsigned integers reporting overflow.+          The first element of the pair is the result.  The second element is+          the carry flag, which is nonzero on overflow.-}+subWordC# :: Word# -> Word# -> (# Word#,Int# #)+subWordC# = subWordC#++{-|Add unsigned integers, with the high part (carry) in the first+          component of the returned pair and the low part in the second+          component of the pair. See also 'addWordC#'.-}+plusWord2# :: Word# -> Word# -> (# Word#,Word# #)+plusWord2# = plusWord2#++minusWord# :: Word# -> Word# -> Word#+minusWord# = minusWord#++timesWord# :: Word# -> Word# -> Word#+timesWord# = timesWord#++timesWord2# :: Word# -> Word# -> (# Word#,Word# #)+timesWord2# = timesWord2#++quotWord# :: Word# -> Word# -> Word#+quotWord# = quotWord#++remWord# :: Word# -> Word# -> Word#+remWord# = remWord#++quotRemWord# :: Word# -> Word# -> (# Word#,Word# #)+quotRemWord# = quotRemWord#++{-| Takes high word of dividend, then low word of dividend, then divisor.+           Requires that high word < divisor.-}+quotRemWord2# :: Word# -> Word# -> Word# -> (# Word#,Word# #)+quotRemWord2# = quotRemWord2#++and# :: Word# -> Word# -> Word#+and# = and#++or# :: Word# -> Word# -> Word#+or# = or#++xor# :: Word# -> Word# -> Word#+xor# = xor#++not# :: Word# -> Word#+not# = not#++{-|Shift left logical.   Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedShiftL# :: Word# -> Int# -> Word#+uncheckedShiftL# = uncheckedShiftL#++{-|Shift right logical.   Result undefined if shift  amount is not+          in the range 0 to word size - 1 inclusive.-}+uncheckedShiftRL# :: Word# -> Int# -> Word#+uncheckedShiftRL# = uncheckedShiftRL#++word2Int# :: Word# -> Int#+word2Int# = word2Int#++gtWord# :: Word# -> Word# -> Int#+gtWord# = gtWord#++geWord# :: Word# -> Word# -> Int#+geWord# = geWord#++eqWord# :: Word# -> Word# -> Int#+eqWord# = eqWord#++neWord# :: Word# -> Word# -> Int#+neWord# = neWord#++ltWord# :: Word# -> Word# -> Int#+ltWord# = ltWord#++leWord# :: Word# -> Word# -> Int#+leWord# = leWord#++{-|Count the number of set bits in the lower 8 bits of a word.-}+popCnt8# :: Word# -> Word#+popCnt8# = popCnt8#++{-|Count the number of set bits in the lower 16 bits of a word.-}+popCnt16# :: Word# -> Word#+popCnt16# = popCnt16#++{-|Count the number of set bits in the lower 32 bits of a word.-}+popCnt32# :: Word# -> Word#+popCnt32# = popCnt32#++{-|Count the number of set bits in a 64-bit word.-}+popCnt64# :: Word64# -> Word#+popCnt64# = popCnt64#++{-|Count the number of set bits in a word.-}+popCnt# :: Word# -> Word#+popCnt# = popCnt#++{-|Deposit bits to lower 8 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pdep8# :: Word# -> Word# -> Word#+pdep8# = pdep8#++{-|Deposit bits to lower 16 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pdep16# :: Word# -> Word# -> Word#+pdep16# = pdep16#++{-|Deposit bits to lower 32 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pdep32# :: Word# -> Word# -> Word#+pdep32# = pdep32#++{-|Deposit bits to a word at locations specified by a mask.++    @since 0.5.2.0-}+pdep64# :: Word64# -> Word64# -> Word64#+pdep64# = pdep64#++{-|Deposit bits to a word at locations specified by a mask, aka+    [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).++    Software emulation:++    > pdep :: Word -> Word -> Word+    > pdep src mask = go 0 src mask+    >   where+    >     go :: Word -> Word -> Word -> Word+    >     go result _ 0 = result+    >     go result src mask = go newResult newSrc newMask+    >       where+    >         maskCtz   = countTrailingZeros mask+    >         newResult = if testBit src 0 then setBit result maskCtz else result+    >         newSrc    = src `shiftR` 1+    >         newMask   = clearBit mask maskCtz++    @since 0.5.2.0-}+pdep# :: Word# -> Word# -> Word#+pdep# = pdep#++{-|Extract bits from lower 8 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pext8# :: Word# -> Word# -> Word#+pext8# = pext8#++{-|Extract bits from lower 16 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pext16# :: Word# -> Word# -> Word#+pext16# = pext16#++{-|Extract bits from lower 32 bits of a word at locations specified by a mask.++    @since 0.5.2.0-}+pext32# :: Word# -> Word# -> Word#+pext32# = pext32#++{-|Extract bits from a word at locations specified by a mask.++    @since 0.5.2.0-}+pext64# :: Word64# -> Word64# -> Word64#+pext64# = pext64#++{-|Extract bits from a word at locations specified by a mask, aka+    [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).++    Software emulation:++    > pext :: Word -> Word -> Word+    > pext src mask = loop 0 0 0+    >   where+    >     loop i count result+    >       | i >= finiteBitSize (0 :: Word)+    >       = result+    >       | testBit mask i+    >       = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result)+    >       | otherwise+    >       = loop (i + 1) count result++    @since 0.5.2.0-}+pext# :: Word# -> Word# -> Word#+pext# = pext#++{-|Count leading zeros in the lower 8 bits of a word.-}+clz8# :: Word# -> Word#+clz8# = clz8#++{-|Count leading zeros in the lower 16 bits of a word.-}+clz16# :: Word# -> Word#+clz16# = clz16#++{-|Count leading zeros in the lower 32 bits of a word.-}+clz32# :: Word# -> Word#+clz32# = clz32#++{-|Count leading zeros in a 64-bit word.-}+clz64# :: Word64# -> Word#+clz64# = clz64#++{-|Count leading zeros in a word.-}+clz# :: Word# -> Word#+clz# = clz#++{-|Count trailing zeros in the lower 8 bits of a word.-}+ctz8# :: Word# -> Word#+ctz8# = ctz8#++{-|Count trailing zeros in the lower 16 bits of a word.-}+ctz16# :: Word# -> Word#+ctz16# = ctz16#++{-|Count trailing zeros in the lower 32 bits of a word.-}+ctz32# :: Word# -> Word#+ctz32# = ctz32#++{-|Count trailing zeros in a 64-bit word.-}+ctz64# :: Word64# -> Word#+ctz64# = ctz64#++{-|Count trailing zeros in a word.-}+ctz# :: Word# -> Word#+ctz# = ctz#++{-|Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. -}+byteSwap16# :: Word# -> Word#+byteSwap16# = byteSwap16#++{-|Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. -}+byteSwap32# :: Word# -> Word#+byteSwap32# = byteSwap32#++{-|Swap bytes in a 64 bits of a word.-}+byteSwap64# :: Word64# -> Word64#+byteSwap64# = byteSwap64#++{-|Swap bytes in a word.-}+byteSwap# :: Word# -> Word#+byteSwap# = byteSwap#++{-|Reverse the order of the bits in a 8-bit word.-}+bitReverse8# :: Word# -> Word#+bitReverse8# = bitReverse8#++{-|Reverse the order of the bits in a 16-bit word.-}+bitReverse16# :: Word# -> Word#+bitReverse16# = bitReverse16#++{-|Reverse the order of the bits in a 32-bit word.-}+bitReverse32# :: Word# -> Word#+bitReverse32# = bitReverse32#++{-|Reverse the order of the bits in a 64-bit word.-}+bitReverse64# :: Word64# -> Word64#+bitReverse64# = bitReverse64#++{-|Reverse the order of the bits in a word.-}+bitReverse# :: Word# -> Word#+bitReverse# = bitReverse#++narrow8Int# :: Int# -> Int#+narrow8Int# = narrow8Int#++narrow16Int# :: Int# -> Int#+narrow16Int# = narrow16Int#++narrow32Int# :: Int# -> Int#+narrow32Int# = narrow32Int#++narrow8Word# :: Word# -> Word#+narrow8Word# = narrow8Word#++narrow16Word# :: Word# -> Word#+narrow16Word# = narrow16Word#++narrow32Word# :: Word# -> Word#+narrow32Word# = narrow32Word#++data Double#++infix 4 >##+(>##) :: Double# -> Double# -> Int#+(>##) = (>##)++infix 4 >=##+(>=##) :: Double# -> Double# -> Int#+(>=##) = (>=##)++infix 4 ==##+(==##) :: Double# -> Double# -> Int#+(==##) = (==##)++infix 4 /=##+(/=##) :: Double# -> Double# -> Int#+(/=##) = (/=##)++infix 4 <##+(<##) :: Double# -> Double# -> Int#+(<##) = (<##)++infix 4 <=##+(<=##) :: Double# -> Double# -> Int#+(<=##) = (<=##)++{-|Return the minimum of the arguments.+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.-}+minDouble# :: Double# -> Double# -> Double#+minDouble# = minDouble#++{-|Return the maximum of the arguments.+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.-}+maxDouble# :: Double# -> Double# -> Double#+maxDouble# = maxDouble#++infixl 6 +##+(+##) :: Double# -> Double# -> Double#+(+##) = (+##)++infixl 6 -##+(-##) :: Double# -> Double# -> Double#+(-##) = (-##)++infixl 7 *##+(*##) :: Double# -> Double# -> Double#+(*##) = (*##)++infixl 7 /##+(/##) :: Double# -> Double# -> Double#+(/##) = (/##)++negateDouble# :: Double# -> Double#+negateDouble# = negateDouble#++fabsDouble# :: Double# -> Double#+fabsDouble# = fabsDouble#++{-|Truncates a 'Double#' value to the nearest 'Int#'.+    Results are undefined if the truncation if truncation yields+    a value outside the range of 'Int#'.-}+double2Int# :: Double# -> Int#+double2Int# = double2Int#++double2Float# :: Double# -> Float#+double2Float# = double2Float#++expDouble# :: Double# -> Double#+expDouble# = expDouble#++expm1Double# :: Double# -> Double#+expm1Double# = expm1Double#++logDouble# :: Double# -> Double#+logDouble# = logDouble#++log1pDouble# :: Double# -> Double#+log1pDouble# = log1pDouble#++sqrtDouble# :: Double# -> Double#+sqrtDouble# = sqrtDouble#++sinDouble# :: Double# -> Double#+sinDouble# = sinDouble#++cosDouble# :: Double# -> Double#+cosDouble# = cosDouble#++tanDouble# :: Double# -> Double#+tanDouble# = tanDouble#++asinDouble# :: Double# -> Double#+asinDouble# = asinDouble#++acosDouble# :: Double# -> Double#+acosDouble# = acosDouble#++atanDouble# :: Double# -> Double#+atanDouble# = atanDouble#++sinhDouble# :: Double# -> Double#+sinhDouble# = sinhDouble#++coshDouble# :: Double# -> Double#+coshDouble# = coshDouble#++tanhDouble# :: Double# -> Double#+tanhDouble# = tanhDouble#++asinhDouble# :: Double# -> Double#+asinhDouble# = asinhDouble#++acoshDouble# :: Double# -> Double#+acoshDouble# = acoshDouble#++atanhDouble# :: Double# -> Double#+atanhDouble# = atanhDouble#++{-|Exponentiation.-}+(**##) :: Double# -> Double# -> Double#+(**##) = (**##)++{-|Convert to integer.+    First component of the result is -1 or 1, indicating the sign of the+    mantissa. The next two are the high and low 32 bits of the mantissa+    respectively, and the last is the exponent.-}+decodeDouble_2Int# :: Double# -> (# Int#,Word#,Word#,Int# #)+decodeDouble_2Int# = decodeDouble_2Int#++{-|Decode 'Double#' into mantissa and base-2 exponent.-}+decodeDouble_Int64# :: Double# -> (# Int64#,Int# #)+decodeDouble_Int64# = decodeDouble_Int64#++{-|Bitcast a 'Double#' into a 'Word64#'-}+castDoubleToWord64# :: Double# -> Word64#+castDoubleToWord64# = castDoubleToWord64#++{-|Bitcast a 'Word64#' into a 'Double#'-}+castWord64ToDouble# :: Word64# -> Double#+castWord64ToDouble# = castWord64ToDouble#++data Float#++gtFloat# :: Float# -> Float# -> Int#+gtFloat# = gtFloat#++geFloat# :: Float# -> Float# -> Int#+geFloat# = geFloat#++eqFloat# :: Float# -> Float# -> Int#+eqFloat# = eqFloat#++neFloat# :: Float# -> Float# -> Int#+neFloat# = neFloat#++ltFloat# :: Float# -> Float# -> Int#+ltFloat# = ltFloat#++leFloat# :: Float# -> Float# -> Int#+leFloat# = leFloat#++{-|Return the minimum of the arguments.+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.-}+minFloat# :: Float# -> Float# -> Float#+minFloat# = minFloat#++{-|Return the maximum of the arguments.+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.-}+maxFloat# :: Float# -> Float# -> Float#+maxFloat# = maxFloat#++plusFloat# :: Float# -> Float# -> Float#+plusFloat# = plusFloat#++minusFloat# :: Float# -> Float# -> Float#+minusFloat# = minusFloat#++timesFloat# :: Float# -> Float# -> Float#+timesFloat# = timesFloat#++divideFloat# :: Float# -> Float# -> Float#+divideFloat# = divideFloat#++negateFloat# :: Float# -> Float#+negateFloat# = negateFloat#++fabsFloat# :: Float# -> Float#+fabsFloat# = fabsFloat#++{-|Truncates a 'Float#' value to the nearest 'Int#'.+    Results are undefined if the truncation if truncation yields+    a value outside the range of 'Int#'.-}+float2Int# :: Float# -> Int#+float2Int# = float2Int#++expFloat# :: Float# -> Float#+expFloat# = expFloat#++expm1Float# :: Float# -> Float#+expm1Float# = expm1Float#++logFloat# :: Float# -> Float#+logFloat# = logFloat#++log1pFloat# :: Float# -> Float#+log1pFloat# = log1pFloat#++sqrtFloat# :: Float# -> Float#+sqrtFloat# = sqrtFloat#++sinFloat# :: Float# -> Float#+sinFloat# = sinFloat#++cosFloat# :: Float# -> Float#+cosFloat# = cosFloat#++tanFloat# :: Float# -> Float#+tanFloat# = tanFloat#++asinFloat# :: Float# -> Float#+asinFloat# = asinFloat#++acosFloat# :: Float# -> Float#+acosFloat# = acosFloat#++atanFloat# :: Float# -> Float#+atanFloat# = atanFloat#++sinhFloat# :: Float# -> Float#+sinhFloat# = sinhFloat#++coshFloat# :: Float# -> Float#+coshFloat# = coshFloat#++tanhFloat# :: Float# -> Float#+tanhFloat# = tanhFloat#++asinhFloat# :: Float# -> Float#+asinhFloat# = asinhFloat#++acoshFloat# :: Float# -> Float#+acoshFloat# = acoshFloat#++atanhFloat# :: Float# -> Float#+atanhFloat# = atanhFloat#++powerFloat# :: Float# -> Float# -> Float#+powerFloat# = powerFloat#++float2Double# :: Float# -> Double#+float2Double# = float2Double#++{-|Convert to integers.+    First 'Int#' in result is the mantissa; second is the exponent.-}+decodeFloat_Int# :: Float# -> (# Int#,Int# #)+decodeFloat_Int# = decodeFloat_Int#++{-|Bitcast a 'Float#' into a 'Word32#'-}+castFloatToWord32# :: Float# -> Word32#+castFloatToWord32# = castFloatToWord32#++{-|Bitcast a 'Word32#' into a 'Float#'-}+castWord32ToFloat# :: Word32# -> Float#+castWord32ToFloat# = castWord32ToFloat#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddFloat# :: Float# -> Float# -> Float# -> Float#+fmaddFloat# = fmaddFloat#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubFloat# :: Float# -> Float# -> Float# -> Float#+fmsubFloat# = fmsubFloat#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddFloat# :: Float# -> Float# -> Float# -> Float#+fnmaddFloat# = fnmaddFloat#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubFloat# :: Float# -> Float# -> Float# -> Float#+fnmsubFloat# = fnmsubFloat#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddDouble# :: Double# -> Double# -> Double# -> Double#+fmaddDouble# = fmaddDouble#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubDouble# :: Double# -> Double# -> Double# -> Double#+fmsubDouble# = fmsubDouble#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddDouble# :: Double# -> Double# -> Double# -> Double#+fnmaddDouble# = fnmaddDouble#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubDouble# :: Double# -> Double# -> Double# -> Double#+fnmsubDouble# = fnmsubDouble#++data Array# a++data MutableArray# s a++{-|Create a new mutable array with the specified number of elements,+    in the specified state thread,+    with each element containing the specified initial value.-}+newArray# :: Int# -> a_levpoly -> State# s -> (# State# s,MutableArray# s a_levpoly #)+newArray# = newArray#++{-|Read from specified index of mutable array. Result is not yet evaluated.++__/Warning:/__ this can fail with an unchecked exception.-}+readArray# :: MutableArray# s a_levpoly -> Int# -> State# s -> (# State# s,a_levpoly #)+readArray# = readArray#++{-|Write to specified index of mutable array.++__/Warning:/__ this can fail with an unchecked exception.-}+writeArray# :: MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+writeArray# = writeArray#++{-|Return the number of elements in the array.-}+sizeofArray# :: Array# a_levpoly -> Int#+sizeofArray# = sizeofArray#++{-|Return the number of elements in the array.-}+sizeofMutableArray# :: MutableArray# s a_levpoly -> Int#+sizeofMutableArray# = sizeofMutableArray#++{-|Read from the specified index of an immutable array. The result is packaged+    into an unboxed unary tuple; the result itself is not yet+    evaluated. Pattern matching on the tuple forces the indexing of the+    array to happen but does not evaluate the element itself. Evaluating+    the thunk prevents additional thunks from building up on the+    heap. Avoiding these thunks, in turn, reduces references to the+    argument array, allowing it to be garbage collected more promptly.-}+indexArray# :: Array# a_levpoly -> Int# -> (# a_levpoly #)+indexArray# = indexArray#++{-|Make a mutable array immutable, without copying.-}+unsafeFreezeArray# :: MutableArray# s a_levpoly -> State# s -> (# State# s,Array# a_levpoly #)+unsafeFreezeArray# = unsafeFreezeArray#++{-|Make an immutable array mutable, without copying.-}+unsafeThawArray# :: Array# a_levpoly -> State# s -> (# State# s,MutableArray# s a_levpoly #)+unsafeThawArray# = unsafeThawArray#++{-|Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. The two arrays must not+   be the same array in different states, but this is not checked+   either.++__/Warning:/__ this can fail with an unchecked exception.-}+copyArray# :: Array# a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copyArray# = copyArray#++{-|Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. In the case where+   the source and destination are the same array the source and+   destination regions may overlap.++__/Warning:/__ this can fail with an unchecked exception.-}+copyMutableArray# :: MutableArray# s a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copyMutableArray# = copyMutableArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+cloneArray# :: Array# a_levpoly -> Int# -> Int# -> Array# a_levpoly+cloneArray# = cloneArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+cloneMutableArray# :: MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,MutableArray# s a_levpoly #)+cloneMutableArray# = cloneMutableArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+freezeArray# :: MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,Array# a_levpoly #)+freezeArray# = freezeArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+thawArray# :: Array# a_levpoly -> Int# -> Int# -> State# s -> (# State# s,MutableArray# s a_levpoly #)+thawArray# = thawArray#++{-|Given an array, an offset, the expected old value, and+    the new value, perform an atomic compare and swap (i.e. write the new+    value if the current value and the old value are the same pointer).+    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns+    the element at the offset after the operation completes. This means that+    on a success the new value is returned, and on a failure the actual old+    value (not the expected one) is returned. Implies a full memory barrier.+    The use of a pointer equality on a boxed value makes this function harder+    to use correctly than 'casIntArray#'. All of the difficulties+    of using 'reallyUnsafePtrEquality#' correctly apply to+    'casArray#' as well.+   ++__/Warning:/__ this can fail with an unchecked exception.-}+casArray# :: MutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casArray# = casArray#++data SmallArray# a++data SmallMutableArray# s a++{-|Create a new mutable array with the specified number of elements,+    in the specified state thread,+    with each element containing the specified initial value.-}+newSmallArray# :: Int# -> a_levpoly -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+newSmallArray# = newSmallArray#++{-|Shrink mutable array to new specified size, in+    the specified state thread. The new size argument must be less than or+    equal to the current size as reported by 'getSizeofSmallMutableArray#'.++    Assuming the non-profiling RTS, for the copying garbage collector+    (default) this primitive compiles to an O(1) operation in C--, modifying+    the array in-place. For the non-moving garbage collector, however, the+    time is proportional to the number of elements shrinked out. Backends+    bypassing C-- representation (such as JavaScript) might behave+    differently.++    @since 0.6.1++__/Warning:/__ this can fail with an unchecked exception.-}+shrinkSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> State# s -> State# s+shrinkSmallMutableArray# = shrinkSmallMutableArray#++{-|Read from specified index of mutable array. Result is not yet evaluated.++__/Warning:/__ this can fail with an unchecked exception.-}+readSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> State# s -> (# State# s,a_levpoly #)+readSmallArray# = readSmallArray#++{-|Write to specified index of mutable array.++__/Warning:/__ this can fail with an unchecked exception.-}+writeSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+writeSmallArray# = writeSmallArray#++{-|Return the number of elements in the array.-}+sizeofSmallArray# :: SmallArray# a_levpoly -> Int#+sizeofSmallArray# = sizeofSmallArray#++{-|Return the number of elements in the array. __Deprecated__, it is+   unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@+   operations on the same small mutable array.-}+{-# DEPRECATED sizeofSmallMutableArray# " Use 'getSizeofSmallMutableArray#' instead " #-}+sizeofSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int#+sizeofSmallMutableArray# = sizeofSmallMutableArray#++{-|Return the number of elements in the array, correctly accounting for+   the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@.++   @since 0.6.1-}+getSizeofSmallMutableArray# :: SmallMutableArray# s a_levpoly -> State# s -> (# State# s,Int# #)+getSizeofSmallMutableArray# = getSizeofSmallMutableArray#++{-|Read from specified index of immutable array. Result is packaged into+    an unboxed singleton; the result itself is not yet evaluated.-}+indexSmallArray# :: SmallArray# a_levpoly -> Int# -> (# a_levpoly #)+indexSmallArray# = indexSmallArray#++{-|Make a mutable array immutable, without copying.-}+unsafeFreezeSmallArray# :: SmallMutableArray# s a_levpoly -> State# s -> (# State# s,SmallArray# a_levpoly #)+unsafeFreezeSmallArray# = unsafeFreezeSmallArray#++{-|Make an immutable array mutable, without copying.-}+unsafeThawSmallArray# :: SmallArray# a_levpoly -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+unsafeThawSmallArray# = unsafeThawSmallArray#++{-|Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. The two arrays must not+   be the same array in different states, but this is not checked+   either.++__/Warning:/__ this can fail with an unchecked exception.-}+copySmallArray# :: SmallArray# a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copySmallArray# = copySmallArray#++{-|Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. The source and destination arrays can+   refer to the same array. Both arrays must fully contain the+   specified ranges, but this is not checked.+   The regions are allowed to overlap, although this is only possible when the same+   array is provided as both the source and the destination. ++__/Warning:/__ this can fail with an unchecked exception.-}+copySmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copySmallMutableArray# = copySmallMutableArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+cloneSmallArray# :: SmallArray# a_levpoly -> Int# -> Int# -> SmallArray# a_levpoly+cloneSmallArray# = cloneSmallArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+cloneSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+cloneSmallMutableArray# = cloneSmallMutableArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+freezeSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallArray# a_levpoly #)+freezeSmallArray# = freezeSmallArray#++{-|Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.++__/Warning:/__ this can fail with an unchecked exception.-}+thawSmallArray# :: SmallArray# a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+thawSmallArray# = thawSmallArray#++{-|Unsafe, machine-level atomic compare and swap on an element within an array.+    See the documentation of 'casArray#'.++__/Warning:/__ this can fail with an unchecked exception.-}+casSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casSmallArray# = casSmallArray#++{-|+  A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,+  which is not scanned for pointers during garbage collection.++  It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.+  Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood.++  The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,+  like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@.++  Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.++  The representation on the heap of a Byte Array is:++  > +------------+-----------------+-----------------------++  > |            |                 |                       |+  > |   HEADER   | SIZE (in bytes) |       PAYLOAD         |+  > |            |                 |                       |+  > +------------+-----------------+-----------------------+++  To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.++  Alternatively, enabling the @UnliftedFFITypes@ extension+  allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.+-}+data ByteArray#++{-| A mutable 'ByteAray#'. It can be created in three ways:++  * 'newByteArray#': Create an unpinned array.+  * 'newPinnedByteArray#': This will create a pinned array,+  * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.++  Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values+  if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,+  because no garbage collection happens during these unsafe calls+  (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)+  in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function+  for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).+-}+data MutableByteArray# s++{-|Create a new mutable byte array of specified size (in bytes), in+    the specified state thread. The size of the memory underlying the+    array will be rounded up to the platform's word size.-}+newByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newByteArray# = newByteArray#++{-|Like 'newByteArray#' but GC guarantees not to move it.-}+newPinnedByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newPinnedByteArray# = newPinnedByteArray#++{-|Like 'newPinnedByteArray#' but allow specifying an arbitrary+    alignment, which must be a power of two.++__/Warning:/__ this can fail with an unchecked exception.-}+newAlignedPinnedByteArray# :: Int# -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+newAlignedPinnedByteArray# = newAlignedPinnedByteArray#++{-|Determine whether a 'MutableByteArray#' is guaranteed not to move+   during GC.-}+isMutableByteArrayPinned# :: MutableByteArray# s -> Int#+isMutableByteArrayPinned# = isMutableByteArrayPinned#++{-|Determine whether a 'ByteArray#' is guaranteed not to move.-}+isByteArrayPinned# :: ByteArray# -> Int#+isByteArrayPinned# = isByteArrayPinned#++{-|Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed+    to be copied into compact regions by the user, potentially invalidating+    the results of earlier calls to 'byteArrayContents#'.++    See the section `Pinned Byte Arrays` in the user guide for more information.++    This function also returns true for regular pinned bytearrays.+   -}+isByteArrayWeaklyPinned# :: ByteArray# -> Int#+isByteArrayWeaklyPinned# = isByteArrayWeaklyPinned#++{-| 'isByteArrayWeaklyPinned#' but for mutable arrays.+   -}+isMutableByteArrayWeaklyPinned# :: MutableByteArray# s -> Int#+isMutableByteArrayWeaklyPinned# = isMutableByteArrayWeaklyPinned#++{-|Intended for use with pinned arrays; otherwise very unsafe!-}+byteArrayContents# :: ByteArray# -> Addr#+byteArrayContents# = byteArrayContents#++{-|Intended for use with pinned arrays; otherwise very unsafe!-}+mutableByteArrayContents# :: MutableByteArray# s -> Addr#+mutableByteArrayContents# = mutableByteArrayContents#++{-|Shrink mutable byte array to new specified size (in bytes), in+    the specified state thread. The new size argument must be less than or+    equal to the current size as reported by 'getSizeofMutableByteArray#'.++    Assuming the non-profiling RTS, this primitive compiles to an O(1)+    operation in C--, modifying the array in-place. Backends bypassing C--+    representation (such as JavaScript) might behave differently.++    @since 0.4.0.0++__/Warning:/__ this can fail with an unchecked exception.-}+shrinkMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> State# s+shrinkMutableByteArray# = shrinkMutableByteArray#++{-|Resize mutable byte array to new specified size (in bytes), shrinking or growing it.+    The returned 'MutableByteArray#' is either the original+    'MutableByteArray#' resized in-place or, if not possible, a newly+    allocated (unpinned) 'MutableByteArray#' (with the original content+    copied over).++    To avoid undefined behaviour, the original 'MutableByteArray#' shall+    not be accessed anymore after a 'resizeMutableByteArray#' has been+    performed.  Moreover, no reference to the old one should be kept in order+    to allow garbage collection of the original 'MutableByteArray#' in+    case a new 'MutableByteArray#' had to be allocated.++    @since 0.4.0.0-}+resizeMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+resizeMutableByteArray# = resizeMutableByteArray#++{-|Make a mutable byte array immutable, without copying.-}+unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> (# State# s,ByteArray# #)+unsafeFreezeByteArray# = unsafeFreezeByteArray#++{-|Make an immutable byte array mutable, without copying.++    @since 0.12.0.0-}+unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s,MutableByteArray# s #)+unsafeThawByteArray# = unsafeThawByteArray#++{-|Return the size of the array in bytes.-}+sizeofByteArray# :: ByteArray# -> Int#+sizeofByteArray# = sizeofByteArray#++{-|Return the size of the array in bytes. __Deprecated__, it is+   unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'+   operations on the same mutable byte+   array.-}+{-# DEPRECATED sizeofMutableByteArray# " Use 'getSizeofMutableByteArray#' instead " #-}+sizeofMutableByteArray# :: MutableByteArray# s -> Int#+sizeofMutableByteArray# = sizeofMutableByteArray#++{-|Return the number of elements in the array, correctly accounting for+   the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.++   @since 0.5.0.0-}+getSizeofMutableByteArray# :: MutableByteArray# s -> State# s -> (# State# s,Int# #)+getSizeofMutableByteArray# = getSizeofMutableByteArray#++{-|Read an 8-bit character from immutable array; offset in bytes.-}+indexCharArray# :: ByteArray# -> Int# -> Char#+indexCharArray# = indexCharArray#++{-|Read a 32-bit character from immutable array; offset in 4-byte words.-}+indexWideCharArray# :: ByteArray# -> Int# -> Char#+indexWideCharArray# = indexWideCharArray#++{-|Read a word-sized integer from immutable array; offset in machine words.-}+indexIntArray# :: ByteArray# -> Int# -> Int#+indexIntArray# = indexIntArray#++{-|Read a word-sized unsigned integer from immutable array; offset in machine words.-}+indexWordArray# :: ByteArray# -> Int# -> Word#+indexWordArray# = indexWordArray#++{-|Read a machine address from immutable array; offset in machine words.-}+indexAddrArray# :: ByteArray# -> Int# -> Addr#+indexAddrArray# = indexAddrArray#++{-|Read a single-precision floating-point value from immutable array; offset in 4-byte words.-}+indexFloatArray# :: ByteArray# -> Int# -> Float#+indexFloatArray# = indexFloatArray#++{-|Read a double-precision floating-point value from immutable array; offset in 8-byte words.-}+indexDoubleArray# :: ByteArray# -> Int# -> Double#+indexDoubleArray# = indexDoubleArray#++{-|Read a 'StablePtr#' value from immutable array; offset in machine words.-}+indexStablePtrArray# :: ByteArray# -> Int# -> StablePtr# a+indexStablePtrArray# = indexStablePtrArray#++{-|Read an 8-bit signed integer from immutable array; offset in bytes.-}+indexInt8Array# :: ByteArray# -> Int# -> Int8#+indexInt8Array# = indexInt8Array#++{-|Read an 8-bit unsigned integer from immutable array; offset in bytes.-}+indexWord8Array# :: ByteArray# -> Int# -> Word8#+indexWord8Array# = indexWord8Array#++{-|Read a 16-bit signed integer from immutable array; offset in 2-byte words.-}+indexInt16Array# :: ByteArray# -> Int# -> Int16#+indexInt16Array# = indexInt16Array#++{-|Read a 16-bit unsigned integer from immutable array; offset in 2-byte words.-}+indexWord16Array# :: ByteArray# -> Int# -> Word16#+indexWord16Array# = indexWord16Array#++{-|Read a 32-bit signed integer from immutable array; offset in 4-byte words.-}+indexInt32Array# :: ByteArray# -> Int# -> Int32#+indexInt32Array# = indexInt32Array#++{-|Read a 32-bit unsigned integer from immutable array; offset in 4-byte words.-}+indexWord32Array# :: ByteArray# -> Int# -> Word32#+indexWord32Array# = indexWord32Array#++{-|Read a 64-bit signed integer from immutable array; offset in 8-byte words.-}+indexInt64Array# :: ByteArray# -> Int# -> Int64#+indexInt64Array# = indexInt64Array#++{-|Read a 64-bit unsigned integer from immutable array; offset in 8-byte words.-}+indexWord64Array# :: ByteArray# -> Int# -> Word64#+indexWord64Array# = indexWord64Array#++{-|Read an 8-bit character from immutable array; offset in bytes.-}+indexWord8ArrayAsChar# :: ByteArray# -> Int# -> Char#+indexWord8ArrayAsChar# = indexWord8ArrayAsChar#++{-|Read a 32-bit character from immutable array; offset in bytes.-}+indexWord8ArrayAsWideChar# :: ByteArray# -> Int# -> Char#+indexWord8ArrayAsWideChar# = indexWord8ArrayAsWideChar#++{-|Read a word-sized integer from immutable array; offset in bytes.-}+indexWord8ArrayAsInt# :: ByteArray# -> Int# -> Int#+indexWord8ArrayAsInt# = indexWord8ArrayAsInt#++{-|Read a word-sized unsigned integer from immutable array; offset in bytes.-}+indexWord8ArrayAsWord# :: ByteArray# -> Int# -> Word#+indexWord8ArrayAsWord# = indexWord8ArrayAsWord#++{-|Read a machine address from immutable array; offset in bytes.-}+indexWord8ArrayAsAddr# :: ByteArray# -> Int# -> Addr#+indexWord8ArrayAsAddr# = indexWord8ArrayAsAddr#++{-|Read a single-precision floating-point value from immutable array; offset in bytes.-}+indexWord8ArrayAsFloat# :: ByteArray# -> Int# -> Float#+indexWord8ArrayAsFloat# = indexWord8ArrayAsFloat#++{-|Read a double-precision floating-point value from immutable array; offset in bytes.-}+indexWord8ArrayAsDouble# :: ByteArray# -> Int# -> Double#+indexWord8ArrayAsDouble# = indexWord8ArrayAsDouble#++{-|Read a 'StablePtr#' value from immutable array; offset in bytes.-}+indexWord8ArrayAsStablePtr# :: ByteArray# -> Int# -> StablePtr# a+indexWord8ArrayAsStablePtr# = indexWord8ArrayAsStablePtr#++{-|Read a 16-bit signed integer from immutable array; offset in bytes.-}+indexWord8ArrayAsInt16# :: ByteArray# -> Int# -> Int16#+indexWord8ArrayAsInt16# = indexWord8ArrayAsInt16#++{-|Read a 16-bit unsigned integer from immutable array; offset in bytes.-}+indexWord8ArrayAsWord16# :: ByteArray# -> Int# -> Word16#+indexWord8ArrayAsWord16# = indexWord8ArrayAsWord16#++{-|Read a 32-bit signed integer from immutable array; offset in bytes.-}+indexWord8ArrayAsInt32# :: ByteArray# -> Int# -> Int32#+indexWord8ArrayAsInt32# = indexWord8ArrayAsInt32#++{-|Read a 32-bit unsigned integer from immutable array; offset in bytes.-}+indexWord8ArrayAsWord32# :: ByteArray# -> Int# -> Word32#+indexWord8ArrayAsWord32# = indexWord8ArrayAsWord32#++{-|Read a 64-bit signed integer from immutable array; offset in bytes.-}+indexWord8ArrayAsInt64# :: ByteArray# -> Int# -> Int64#+indexWord8ArrayAsInt64# = indexWord8ArrayAsInt64#++{-|Read a 64-bit unsigned integer from immutable array; offset in bytes.-}+indexWord8ArrayAsWord64# :: ByteArray# -> Int# -> Word64#+indexWord8ArrayAsWord64# = indexWord8ArrayAsWord64#++{-|Read an 8-bit character from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readCharArray# = readCharArray#++{-|Read a 32-bit character from mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWideCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWideCharArray# = readWideCharArray#++{-|Read a word-sized integer from mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+readIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readIntArray# = readIntArray#++{-|Read a word-sized unsigned integer from mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWordArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWordArray# = readWordArray#++{-|Read a machine address from mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readAddrArray# = readAddrArray#++{-|Read a single-precision floating-point value from mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readFloatArray# = readFloatArray#++{-|Read a double-precision floating-point value from mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readDoubleArray# = readDoubleArray#++{-|Read a 'StablePtr#' value from mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+readStablePtrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrArray# = readStablePtrArray#++{-|Read an 8-bit signed integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8# #)+readInt8Array# = readInt8Array#++{-|Read an 8-bit unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8# #)+readWord8Array# = readWord8Array#++{-|Read a 16-bit signed integer from mutable array; offset in 2-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16# #)+readInt16Array# = readInt16Array#++{-|Read a 16-bit unsigned integer from mutable array; offset in 2-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16# #)+readWord16Array# = readWord16Array#++{-|Read a 32-bit signed integer from mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32# #)+readInt32Array# = readInt32Array#++{-|Read a 32-bit unsigned integer from mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32# #)+readWord32Array# = readWord32Array#++{-|Read a 64-bit signed integer from mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64# #)+readInt64Array# = readInt64Array#++{-|Read a 64-bit unsigned integer from mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64# #)+readWord64Array# = readWord64Array#++{-|Read an 8-bit character from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsChar# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWord8ArrayAsChar# = readWord8ArrayAsChar#++{-|Read a 32-bit character from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWideChar# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWord8ArrayAsWideChar# = readWord8ArrayAsWideChar#++{-|Read a word-sized integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsInt# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readWord8ArrayAsInt# = readWord8ArrayAsInt#++{-|Read a word-sized unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord8ArrayAsWord# = readWord8ArrayAsWord#++{-|Read a machine address from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsAddr# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readWord8ArrayAsAddr# = readWord8ArrayAsAddr#++{-|Read a single-precision floating-point value from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsFloat# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readWord8ArrayAsFloat# = readWord8ArrayAsFloat#++{-|Read a double-precision floating-point value from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsDouble# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readWord8ArrayAsDouble# = readWord8ArrayAsDouble#++{-|Read a 'StablePtr#' value from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsStablePtr# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readWord8ArrayAsStablePtr# = readWord8ArrayAsStablePtr#++{-|Read a 16-bit signed integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsInt16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16# #)+readWord8ArrayAsInt16# = readWord8ArrayAsInt16#++{-|Read a 16-bit unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16# #)+readWord8ArrayAsWord16# = readWord8ArrayAsWord16#++{-|Read a 32-bit signed integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsInt32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32# #)+readWord8ArrayAsInt32# = readWord8ArrayAsInt32#++{-|Read a 32-bit unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32# #)+readWord8ArrayAsWord32# = readWord8ArrayAsWord32#++{-|Read a 64-bit signed integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsInt64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64# #)+readWord8ArrayAsInt64# = readWord8ArrayAsInt64#++{-|Read a 64-bit unsigned integer from mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64# #)+readWord8ArrayAsWord64# = readWord8ArrayAsWord64#++{-|Write an 8-bit character to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeCharArray# = writeCharArray#++{-|Write a 32-bit character to mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWideCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWideCharArray# = writeWideCharArray#++{-|Write a word-sized integer to mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeIntArray# = writeIntArray#++{-|Write a word-sized unsigned integer to mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWordArray# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWordArray# = writeWordArray#++{-|Write a machine address to mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeAddrArray# = writeAddrArray#++{-|Write a single-precision floating-point value to mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeFloatArray# = writeFloatArray#++{-|Write a double-precision floating-point value to mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeDoubleArray# = writeDoubleArray#++{-|Write a 'StablePtr#' value to mutable array; offset in machine words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeStablePtrArray# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrArray# = writeStablePtrArray#++{-|Write an 8-bit signed integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8Array# :: MutableByteArray# s -> Int# -> Int8# -> State# s -> State# s+writeInt8Array# = writeInt8Array#++{-|Write an 8-bit unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8Array# :: MutableByteArray# s -> Int# -> Word8# -> State# s -> State# s+writeWord8Array# = writeWord8Array#++{-|Write a 16-bit signed integer to mutable array; offset in 2-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16Array# :: MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+writeInt16Array# = writeInt16Array#++{-|Write a 16-bit unsigned integer to mutable array; offset in 2-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16Array# :: MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+writeWord16Array# = writeWord16Array#++{-|Write a 32-bit signed integer to mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32Array# :: MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+writeInt32Array# = writeInt32Array#++{-|Write a 32-bit unsigned integer to mutable array; offset in 4-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32Array# :: MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+writeWord32Array# = writeWord32Array#++{-|Write a 64-bit signed integer to mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64Array# :: MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+writeInt64Array# = writeInt64Array#++{-|Write a 64-bit unsigned integer to mutable array; offset in 8-byte words.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64Array# :: MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+writeWord64Array# = writeWord64Array#++{-|Write an 8-bit character to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsChar# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWord8ArrayAsChar# = writeWord8ArrayAsChar#++{-|Write a 32-bit character to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWideChar# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWord8ArrayAsWideChar# = writeWord8ArrayAsWideChar#++{-|Write a word-sized integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsInt# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeWord8ArrayAsInt# = writeWord8ArrayAsInt#++{-|Write a word-sized unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord8ArrayAsWord# = writeWord8ArrayAsWord#++{-|Write a machine address to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsAddr# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeWord8ArrayAsAddr# = writeWord8ArrayAsAddr#++{-|Write a single-precision floating-point value to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsFloat# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeWord8ArrayAsFloat# = writeWord8ArrayAsFloat#++{-|Write a double-precision floating-point value to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsDouble# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeWord8ArrayAsDouble# = writeWord8ArrayAsDouble#++{-|Write a 'StablePtr#' value to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsStablePtr# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeWord8ArrayAsStablePtr# = writeWord8ArrayAsStablePtr#++{-|Write a 16-bit signed integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsInt16# :: MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+writeWord8ArrayAsInt16# = writeWord8ArrayAsInt16#++{-|Write a 16-bit unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord16# :: MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+writeWord8ArrayAsWord16# = writeWord8ArrayAsWord16#++{-|Write a 32-bit signed integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsInt32# :: MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+writeWord8ArrayAsInt32# = writeWord8ArrayAsInt32#++{-|Write a 32-bit unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord32# :: MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+writeWord8ArrayAsWord32# = writeWord8ArrayAsWord32#++{-|Write a 64-bit signed integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsInt64# :: MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+writeWord8ArrayAsInt64# = writeWord8ArrayAsInt64#++{-|Write a 64-bit unsigned integer to mutable array; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord64# :: MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+writeWord8ArrayAsWord64# = writeWord8ArrayAsWord64#++{-|@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares+    @n@ bytes starting at offset @src1_ofs@ in the first+    'ByteArray#' @src1@ to the range of @n@ bytes+    (i.e. same length) starting at offset @src2_ofs@ of the second+    'ByteArray#' @src2@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  Returns an 'Int#'+    less than, equal to, or greater than zero if the range is found,+    respectively, to be byte-wise lexicographically less than, to+    match, or be greater than the second range.++    @since 0.5.2.0-}+compareByteArrays# :: ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#+compareByteArrays# = compareByteArrays#++{-| @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range+    starting at offset @src_ofs@ of length @len@ from the+    'ByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain+    the specified ranges, but this is not checked.  The two arrays must+    not be the same array in different states, but this is not checked+    either.+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyByteArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyByteArray# = copyByteArray#++{-| @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the+    range starting at offset @src_ofs@ of length @len@ from the+    'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  The regions are+    allowed to overlap, although this is only possible when the same+    array is provided as both the source and the destination.+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyMutableByteArray# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyMutableByteArray# = copyMutableByteArray#++{-| @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@+    copies the range starting at offset @src_ofs@ of length @len@ from+    the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  The regions are /not/+    allowed to overlap, but this is also not checked.++    @since 0.11.0+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyMutableByteArrayNonOverlapping# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyMutableByteArrayNonOverlapping# = copyMutableByteArrayNonOverlapping#++{-|Copy a range of the ByteArray\# to the memory range starting at the Addr\#.+   The ByteArray\# and the memory region at Addr\# must fully contain the+   specified ranges, but this is not checked. The Addr\# must not point into the+   ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked+   either.++__/Warning:/__ this can fail with an unchecked exception.-}+copyByteArrayToAddr# :: ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s+copyByteArrayToAddr# = copyByteArrayToAddr#++{-|Copy a range of the MutableByteArray\# to the memory range starting at the+   Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully+   contain the specified ranges, but this is not checked. The Addr\# must not+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were+   pinned), but this is not checked either.++__/Warning:/__ this can fail with an unchecked exception.-}+copyMutableByteArrayToAddr# :: MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s+copyMutableByteArrayToAddr# = copyMutableByteArrayToAddr#++{-|Copy a memory range starting at the Addr\# to the specified range in the+   MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully+   contain the specified ranges, but this is not checked. The Addr\# must not+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned),+   but this is not checked either.++__/Warning:/__ this can fail with an unchecked exception.-}+copyAddrToByteArray# :: Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyAddrToByteArray# = copyAddrToByteArray#++{-| @'copyAddrToAddr#' src dest len@ copies @len@ bytes+    from @src@ to @dest@.  These two memory ranges are allowed to overlap.++    Analogous to the standard C function @memmove@, but with a different+    argument order.++    @since 0.11.0+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyAddrToAddr# :: Addr# -> Addr# -> Int# -> State# (RealWorld) -> State# (RealWorld)+copyAddrToAddr# = copyAddrToAddr#++{-| @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes+    from @src@ to @dest@.  As the name suggests, these two memory ranges+    /must not overlap/, although this pre-condition is not checked.++    Analogous to the standard C function @memcpy@, but with a different+    argument order.++    @since 0.11.0+  ++__/Warning:/__ this can fail with an unchecked exception.-}+copyAddrToAddrNonOverlapping# :: Addr# -> Addr# -> Int# -> State# (RealWorld) -> State# (RealWorld)+copyAddrToAddrNonOverlapping# = copyAddrToAddrNonOverlapping#++{-|@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of+   the 'MutableByteArray#' to the byte @c@.++__/Warning:/__ this can fail with an unchecked exception.-}+setByteArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s+setByteArray# = setByteArray#++{-| @'setAddrRange#' dest len c@ sets all of the bytes in+    @[dest, dest+len)@ to the value @c@.++    Analogous to the standard C function @memset@, but with a different+    argument order.++    @since 0.11.0+  ++__/Warning:/__ this can fail with an unchecked exception.-}+setAddrRange# :: Addr# -> Int# -> Int# -> State# (RealWorld) -> State# (RealWorld)+setAddrRange# = setAddrRange#++{-|Given an array and an offset in machine words, read an element. The+    index is assumed to be in bounds. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicReadIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+atomicReadIntArray# = atomicReadIntArray#++{-|Given an array and an offset in machine words, write an element. The+    index is assumed to be in bounds. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicWriteIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+atomicWriteIntArray# = atomicWriteIntArray#++{-|Given an array, an offset in machine words, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casIntArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s,Int# #)+casIntArray# = casIntArray#++{-|Given an array, an offset in bytes, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casInt8Array# :: MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s,Int8# #)+casInt8Array# = casInt8Array#++{-|Given an array, an offset in 16 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casInt16Array# :: MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s,Int16# #)+casInt16Array# = casInt16Array#++{-|Given an array, an offset in 32 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casInt32Array# :: MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s,Int32# #)+casInt32Array# = casInt32Array#++{-|Given an array, an offset in 64 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+casInt64Array# :: MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s,Int64# #)+casInt64Array# = casInt64Array#++{-|Given an array, and offset in machine words, and a value to add,+    atomically add the value to the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchAddIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchAddIntArray# = fetchAddIntArray#++{-|Given an array, and offset in machine words, and a value to subtract,+    atomically subtract the value from the element. Returns the value of+    the element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchSubIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchSubIntArray# = fetchSubIntArray#++{-|Given an array, and offset in machine words, and a value to AND,+    atomically AND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchAndIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchAndIntArray# = fetchAndIntArray#++{-|Given an array, and offset in machine words, and a value to NAND,+    atomically NAND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchNandIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchNandIntArray# = fetchNandIntArray#++{-|Given an array, and offset in machine words, and a value to OR,+    atomically OR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchOrIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchOrIntArray# = fetchOrIntArray#++{-|Given an array, and offset in machine words, and a value to XOR,+    atomically XOR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchXorIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchXorIntArray# = fetchXorIntArray#++{-| An arbitrary machine address assumed to point outside+         the garbage-collected heap. -}+data Addr#++{-| The null address. -}+nullAddr# :: Addr#+nullAddr# = nullAddr#++plusAddr# :: Addr# -> Int# -> Addr#+plusAddr# = plusAddr#++{-|Result is meaningless if two 'Addr#'s are so far apart that their+         difference doesn't fit in an 'Int#'.-}+minusAddr# :: Addr# -> Addr# -> Int#+minusAddr# = minusAddr#++{-|Return the remainder when the 'Addr#' arg, treated like an 'Int#',+          is divided by the 'Int#' arg.-}+remAddr# :: Addr# -> Int# -> Int#+remAddr# = remAddr#++{-|Coerce directly from address to int. Users are discouraged from using+         this operation as it makes little sense on platforms with tagged pointers.-}+addr2Int# :: Addr# -> Int#+addr2Int# = addr2Int#++{-|Coerce directly from int to address. Users are discouraged from using+         this operation as it makes little sense on platforms with tagged pointers.-}+int2Addr# :: Int# -> Addr#+int2Addr# = int2Addr#++gtAddr# :: Addr# -> Addr# -> Int#+gtAddr# = gtAddr#++geAddr# :: Addr# -> Addr# -> Int#+geAddr# = geAddr#++eqAddr# :: Addr# -> Addr# -> Int#+eqAddr# = eqAddr#++neAddr# :: Addr# -> Addr# -> Int#+neAddr# = neAddr#++ltAddr# :: Addr# -> Addr# -> Int#+ltAddr# = ltAddr#++leAddr# :: Addr# -> Addr# -> Int#+leAddr# = leAddr#++{-|Read an 8-bit character from immutable address; offset in bytes.++-}+indexCharOffAddr# :: Addr# -> Int# -> Char#+indexCharOffAddr# = indexCharOffAddr#++{-|Read a 32-bit character from immutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWideCharOffAddr# :: Addr# -> Int# -> Char#+indexWideCharOffAddr# = indexWideCharOffAddr#++{-|Read a word-sized integer from immutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexIntOffAddr# :: Addr# -> Int# -> Int#+indexIntOffAddr# = indexIntOffAddr#++{-|Read a word-sized unsigned integer from immutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWordOffAddr# :: Addr# -> Int# -> Word#+indexWordOffAddr# = indexWordOffAddr#++{-|Read a machine address from immutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexAddrOffAddr# :: Addr# -> Int# -> Addr#+indexAddrOffAddr# = indexAddrOffAddr#++{-|Read a single-precision floating-point value from immutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexFloatOffAddr# :: Addr# -> Int# -> Float#+indexFloatOffAddr# = indexFloatOffAddr#++{-|Read a double-precision floating-point value from immutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexDoubleOffAddr# :: Addr# -> Int# -> Double#+indexDoubleOffAddr# = indexDoubleOffAddr#++{-|Read a 'StablePtr#' value from immutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a+indexStablePtrOffAddr# = indexStablePtrOffAddr#++{-|Read an 8-bit signed integer from immutable address; offset in bytes.++-}+indexInt8OffAddr# :: Addr# -> Int# -> Int8#+indexInt8OffAddr# = indexInt8OffAddr#++{-|Read an 8-bit unsigned integer from immutable address; offset in bytes.++-}+indexWord8OffAddr# :: Addr# -> Int# -> Word8#+indexWord8OffAddr# = indexWord8OffAddr#++{-|Read a 16-bit signed integer from immutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexInt16OffAddr# :: Addr# -> Int# -> Int16#+indexInt16OffAddr# = indexInt16OffAddr#++{-|Read a 16-bit unsigned integer from immutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWord16OffAddr# :: Addr# -> Int# -> Word16#+indexWord16OffAddr# = indexWord16OffAddr#++{-|Read a 32-bit signed integer from immutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexInt32OffAddr# :: Addr# -> Int# -> Int32#+indexInt32OffAddr# = indexInt32OffAddr#++{-|Read a 32-bit unsigned integer from immutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWord32OffAddr# :: Addr# -> Int# -> Word32#+indexWord32OffAddr# = indexWord32OffAddr#++{-|Read a 64-bit signed integer from immutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexInt64OffAddr# :: Addr# -> Int# -> Int64#+indexInt64OffAddr# = indexInt64OffAddr#++{-|Read a 64-bit unsigned integer from immutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.-}+indexWord64OffAddr# :: Addr# -> Int# -> Word64#+indexWord64OffAddr# = indexWord64OffAddr#++{-|Read an 8-bit character from immutable address; offset in bytes.-}+indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char#+indexWord8OffAddrAsChar# = indexWord8OffAddrAsChar#++{-|Read a 32-bit character from immutable address; offset in bytes.-}+indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char#+indexWord8OffAddrAsWideChar# = indexWord8OffAddrAsWideChar#++{-|Read a word-sized integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int#+indexWord8OffAddrAsInt# = indexWord8OffAddrAsInt#++{-|Read a word-sized unsigned integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word#+indexWord8OffAddrAsWord# = indexWord8OffAddrAsWord#++{-|Read a machine address from immutable address; offset in bytes.-}+indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr#+indexWord8OffAddrAsAddr# = indexWord8OffAddrAsAddr#++{-|Read a single-precision floating-point value from immutable address; offset in bytes.-}+indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float#+indexWord8OffAddrAsFloat# = indexWord8OffAddrAsFloat#++{-|Read a double-precision floating-point value from immutable address; offset in bytes.-}+indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double#+indexWord8OffAddrAsDouble# = indexWord8OffAddrAsDouble#++{-|Read a 'StablePtr#' value from immutable address; offset in bytes.-}+indexWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# a+indexWord8OffAddrAsStablePtr# = indexWord8OffAddrAsStablePtr#++{-|Read a 16-bit signed integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16#+indexWord8OffAddrAsInt16# = indexWord8OffAddrAsInt16#++{-|Read a 16-bit unsigned integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16#+indexWord8OffAddrAsWord16# = indexWord8OffAddrAsWord16#++{-|Read a 32-bit signed integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32#+indexWord8OffAddrAsInt32# = indexWord8OffAddrAsInt32#++{-|Read a 32-bit unsigned integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32#+indexWord8OffAddrAsWord32# = indexWord8OffAddrAsWord32#++{-|Read a 64-bit signed integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64#+indexWord8OffAddrAsInt64# = indexWord8OffAddrAsInt64#++{-|Read a 64-bit unsigned integer from immutable address; offset in bytes.-}+indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64#+indexWord8OffAddrAsWord64# = indexWord8OffAddrAsWord64#++{-|Read an 8-bit character from mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+readCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readCharOffAddr# = readCharOffAddr#++{-|Read a 32-bit character from mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWideCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWideCharOffAddr# = readWideCharOffAddr#++{-|Read a word-sized integer from mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readIntOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readIntOffAddr# = readIntOffAddr#++{-|Read a word-sized unsigned integer from mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWordOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWordOffAddr# = readWordOffAddr#++{-|Read a machine address from mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readAddrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readAddrOffAddr# = readAddrOffAddr#++{-|Read a single-precision floating-point value from mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readFloatOffAddr# = readFloatOffAddr#++{-|Read a double-precision floating-point value from mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readDoubleOffAddr# = readDoubleOffAddr#++{-|Read a 'StablePtr#' value from mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readStablePtrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrOffAddr# = readStablePtrOffAddr#++{-|Read an 8-bit signed integer from mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8# #)+readInt8OffAddr# = readInt8OffAddr#++{-|Read an 8-bit unsigned integer from mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8# #)+readWord8OffAddr# = readWord8OffAddr#++{-|Read a 16-bit signed integer from mutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16# #)+readInt16OffAddr# = readInt16OffAddr#++{-|Read a 16-bit unsigned integer from mutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16# #)+readWord16OffAddr# = readWord16OffAddr#++{-|Read a 32-bit signed integer from mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32# #)+readInt32OffAddr# = readInt32OffAddr#++{-|Read a 32-bit unsigned integer from mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32# #)+readWord32OffAddr# = readWord32OffAddr#++{-|Read a 64-bit signed integer from mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64# #)+readInt64OffAddr# = readInt64OffAddr#++{-|Read a 64-bit unsigned integer from mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64# #)+readWord64OffAddr# = readWord64OffAddr#++{-|Read an 8-bit character from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsChar# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWord8OffAddrAsChar# = readWord8OffAddrAsChar#++{-|Read a 32-bit character from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWideChar# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWord8OffAddrAsWideChar# = readWord8OffAddrAsWideChar#++{-|Read a word-sized integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsInt# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readWord8OffAddrAsInt# = readWord8OffAddrAsInt#++{-|Read a word-sized unsigned integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord8OffAddrAsWord# = readWord8OffAddrAsWord#++{-|Read a machine address from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readWord8OffAddrAsAddr# = readWord8OffAddrAsAddr#++{-|Read a single-precision floating-point value from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsFloat# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readWord8OffAddrAsFloat# = readWord8OffAddrAsFloat#++{-|Read a double-precision floating-point value from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsDouble# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readWord8OffAddrAsDouble# = readWord8OffAddrAsDouble#++{-|Read a 'StablePtr#' value from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsStablePtr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readWord8OffAddrAsStablePtr# = readWord8OffAddrAsStablePtr#++{-|Read a 16-bit signed integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsInt16# :: Addr# -> Int# -> State# s -> (# State# s,Int16# #)+readWord8OffAddrAsInt16# = readWord8OffAddrAsInt16#++{-|Read a 16-bit unsigned integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord16# :: Addr# -> Int# -> State# s -> (# State# s,Word16# #)+readWord8OffAddrAsWord16# = readWord8OffAddrAsWord16#++{-|Read a 32-bit signed integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsInt32# :: Addr# -> Int# -> State# s -> (# State# s,Int32# #)+readWord8OffAddrAsInt32# = readWord8OffAddrAsInt32#++{-|Read a 32-bit unsigned integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord32# :: Addr# -> Int# -> State# s -> (# State# s,Word32# #)+readWord8OffAddrAsWord32# = readWord8OffAddrAsWord32#++{-|Read a 64-bit signed integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsInt64# :: Addr# -> Int# -> State# s -> (# State# s,Int64# #)+readWord8OffAddrAsInt64# = readWord8OffAddrAsInt64#++{-|Read a 64-bit unsigned integer from mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord64# :: Addr# -> Int# -> State# s -> (# State# s,Word64# #)+readWord8OffAddrAsWord64# = readWord8OffAddrAsWord64#++{-|Write an 8-bit character to mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+writeCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeCharOffAddr# = writeCharOffAddr#++{-|Write a 32-bit character to mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWideCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWideCharOffAddr# = writeWideCharOffAddr#++{-|Write a word-sized integer to mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeIntOffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeIntOffAddr# = writeIntOffAddr#++{-|Write a word-sized unsigned integer to mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWordOffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWordOffAddr# = writeWordOffAddr#++{-|Write a machine address to mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeAddrOffAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeAddrOffAddr# = writeAddrOffAddr#++{-|Write a single-precision floating-point value to mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatOffAddr# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeFloatOffAddr# = writeFloatOffAddr#++{-|Write a double-precision floating-point value to mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleOffAddr# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeDoubleOffAddr# = writeDoubleOffAddr#++{-|Write a 'StablePtr#' value to mutable address; offset in machine words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrOffAddr# = writeStablePtrOffAddr#++{-|Write an 8-bit signed integer to mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8OffAddr# :: Addr# -> Int# -> Int8# -> State# s -> State# s+writeInt8OffAddr# = writeInt8OffAddr#++{-|Write an 8-bit unsigned integer to mutable address; offset in bytes.++++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddr# :: Addr# -> Int# -> Word8# -> State# s -> State# s+writeWord8OffAddr# = writeWord8OffAddr#++{-|Write a 16-bit signed integer to mutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16OffAddr# :: Addr# -> Int# -> Int16# -> State# s -> State# s+writeInt16OffAddr# = writeInt16OffAddr#++{-|Write a 16-bit unsigned integer to mutable address; offset in 2-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16OffAddr# :: Addr# -> Int# -> Word16# -> State# s -> State# s+writeWord16OffAddr# = writeWord16OffAddr#++{-|Write a 32-bit signed integer to mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32OffAddr# :: Addr# -> Int# -> Int32# -> State# s -> State# s+writeInt32OffAddr# = writeInt32OffAddr#++{-|Write a 32-bit unsigned integer to mutable address; offset in 4-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32OffAddr# :: Addr# -> Int# -> Word32# -> State# s -> State# s+writeWord32OffAddr# = writeWord32OffAddr#++{-|Write a 64-bit signed integer to mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64OffAddr# :: Addr# -> Int# -> Int64# -> State# s -> State# s+writeInt64OffAddr# = writeInt64OffAddr#++{-|Write a 64-bit unsigned integer to mutable address; offset in 8-byte words.++On some platforms, the access may fail+for an insufficiently aligned @Addr#@.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64OffAddr# :: Addr# -> Int# -> Word64# -> State# s -> State# s+writeWord64OffAddr# = writeWord64OffAddr#++{-|Write an 8-bit character to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsChar# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWord8OffAddrAsChar# = writeWord8OffAddrAsChar#++{-|Write a 32-bit character to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWord8OffAddrAsWideChar# = writeWord8OffAddrAsWideChar#++{-|Write a word-sized integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsInt# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeWord8OffAddrAsInt# = writeWord8OffAddrAsInt#++{-|Write a word-sized unsigned integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord8OffAddrAsWord# = writeWord8OffAddrAsWord#++{-|Write a machine address to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeWord8OffAddrAsAddr# = writeWord8OffAddrAsAddr#++{-|Write a single-precision floating-point value to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeWord8OffAddrAsFloat# = writeWord8OffAddrAsFloat#++{-|Write a double-precision floating-point value to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeWord8OffAddrAsDouble# = writeWord8OffAddrAsDouble#++{-|Write a 'StablePtr#' value to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeWord8OffAddrAsStablePtr# = writeWord8OffAddrAsStablePtr#++{-|Write a 16-bit signed integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# -> State# s -> State# s+writeWord8OffAddrAsInt16# = writeWord8OffAddrAsInt16#++{-|Write a 16-bit unsigned integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# -> State# s -> State# s+writeWord8OffAddrAsWord16# = writeWord8OffAddrAsWord16#++{-|Write a 32-bit signed integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# -> State# s -> State# s+writeWord8OffAddrAsInt32# = writeWord8OffAddrAsInt32#++{-|Write a 32-bit unsigned integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# -> State# s -> State# s+writeWord8OffAddrAsWord32# = writeWord8OffAddrAsWord32#++{-|Write a 64-bit signed integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# -> State# s -> State# s+writeWord8OffAddrAsInt64# = writeWord8OffAddrAsInt64#++{-|Write a 64-bit unsigned integer to mutable address; offset in bytes.++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# -> State# s -> State# s+writeWord8OffAddrAsWord64# = writeWord8OffAddrAsWord64#++{-|The atomic exchange operation. Atomically exchanges the value at the first address+    with the Addr# given as second argument. Implies a read barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicExchangeAddrAddr# :: Addr# -> Addr# -> State# s -> (# State# s,Addr# #)+atomicExchangeAddrAddr# = atomicExchangeAddrAddr#++{-|The atomic exchange operation. Atomically exchanges the value at the address+    with the given value. Returns the old value. Implies a read barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicExchangeWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+atomicExchangeWordAddr# = atomicExchangeWordAddr#++{-| Compare and swap on a word-sized memory location.++     Use as: \s -> atomicCasAddrAddr# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasAddrAddr# :: Addr# -> Addr# -> Addr# -> State# s -> (# State# s,Addr# #)+atomicCasAddrAddr# = atomicCasAddrAddr#++{-| Compare and swap on a word-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWordAddr# :: Addr# -> Word# -> Word# -> State# s -> (# State# s,Word# #)+atomicCasWordAddr# = atomicCasWordAddr#++{-| Compare and swap on a 8 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr8# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWord8Addr# :: Addr# -> Word8# -> Word8# -> State# s -> (# State# s,Word8# #)+atomicCasWord8Addr# = atomicCasWord8Addr#++{-| Compare and swap on a 16 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr16# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWord16Addr# :: Addr# -> Word16# -> Word16# -> State# s -> (# State# s,Word16# #)+atomicCasWord16Addr# = atomicCasWord16Addr#++{-| Compare and swap on a 32 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr32# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWord32Addr# :: Addr# -> Word32# -> Word32# -> State# s -> (# State# s,Word32# #)+atomicCasWord32Addr# = atomicCasWord32Addr#++{-| Compare and swap on a 64 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr64# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicCasWord64Addr# :: Addr# -> Word64# -> Word64# -> State# s -> (# State# s,Word64# #)+atomicCasWord64Addr# = atomicCasWord64Addr#++{-|Given an address, and a value to add,+    atomically add the value to the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchAddWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchAddWordAddr# = fetchAddWordAddr#++{-|Given an address, and a value to subtract,+    atomically subtract the value from the element. Returns the value of+    the element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchSubWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchSubWordAddr# = fetchSubWordAddr#++{-|Given an address, and a value to AND,+    atomically AND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchAndWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchAndWordAddr# = fetchAndWordAddr#++{-|Given an address, and a value to NAND,+    atomically NAND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchNandWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchNandWordAddr# = fetchNandWordAddr#++{-|Given an address, and a value to OR,+    atomically OR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchOrWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchOrWordAddr# = fetchOrWordAddr#++{-|Given an address, and a value to XOR,+    atomically XOR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+fetchXorWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchXorWordAddr# = fetchXorWordAddr#++{-|Given an address, read a machine word.  Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicReadWordAddr# :: Addr# -> State# s -> (# State# s,Word# #)+atomicReadWordAddr# = atomicReadWordAddr#++{-|Given an address, write a machine word. Implies a full memory barrier.++__/Warning:/__ this can fail with an unchecked exception.-}+atomicWriteWordAddr# :: Addr# -> Word# -> State# s -> State# s+atomicWriteWordAddr# = atomicWriteWordAddr#++{-|A 'MutVar#' behaves like a single-element mutable array.-}+data MutVar# s a++{-|Create 'MutVar#' with specified initial value in specified state thread.-}+newMutVar# :: a_levpoly -> State# s -> (# State# s,MutVar# s a_levpoly #)+newMutVar# = newMutVar#++{-|Read contents of 'MutVar#'. Result is not yet evaluated.-}+readMutVar# :: MutVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readMutVar# = readMutVar#++{-|Write contents of 'MutVar#'.-}+writeMutVar# :: MutVar# s a_levpoly -> a_levpoly -> State# s -> State# s+writeMutVar# = writeMutVar#++{-|Atomically exchange the value of a 'MutVar#'.-}+atomicSwapMutVar# :: MutVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s,a_levpoly #)+atomicSwapMutVar# = atomicSwapMutVar#++{-| Modify the contents of a 'MutVar#', returning the previous+     contents @x :: a@ and the result of applying the given function to the+     previous contents @f x :: c@.++     The @data@ type @c@ (not a @newtype@!) must be a record whose first field+     is of lifted type @a :: Type@ and is not unpacked. For example, product+     types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both+     monomorphic and strict in its first field, it's recommended to mark the+     latter @{-# NOUNPACK #-}@ explicitly.++     Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an+     old @x :: a@ with a pointer to a selector thunk @fst r@, where+     @fst@ is a selector for the first field of the record and @r@ is a+     function application thunk @r = f x@.++     @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an+     effort to reflect restrictions on @c@ faithfully, providing a+     well-typed high-level wrapper.-}+atomicModifyMutVar2# :: MutVar# s a -> (a -> c) -> State# s -> (# State# s,a,c #)+atomicModifyMutVar2# = atomicModifyMutVar2#++{-| Modify the contents of a 'MutVar#', returning the previous+     contents and the result of applying the given function to the+     previous contents. -}+atomicModifyMutVar_# :: MutVar# s a -> (a -> a) -> State# s -> (# State# s,a,a #)+atomicModifyMutVar_# = atomicModifyMutVar_#++{-| Compare-and-swap: perform a pointer equality test between+     the first value passed to this function and the value+     stored inside the 'MutVar#'. If the pointers are equal,+     replace the stored value with the second value passed to this+     function, otherwise do nothing.+     Returns the final value stored inside the 'MutVar#'.+     The 'Int#' indicates whether a swap took place,+     with @1#@ meaning that we didn't swap, and @0#@+     that we did.+     Implies a full memory barrier.+     Because the comparison is done on the level of pointers,+     all of the difficulties of using+     'reallyUnsafePtrEquality#' correctly apply to+     'casMutVar#' as well.+   -}+casMutVar# :: MutVar# s a_levpoly -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casMutVar# = casMutVar#++{-| @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions+     thrown.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+catch# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> (b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+catch# = catch#++raise# :: a_levpoly -> b_reppoly+raise# = raise#++raiseUnderflow# :: (#  #) -> b_reppoly+raiseUnderflow# = raiseUnderflow#++raiseOverflow# :: (#  #) -> b_reppoly+raiseOverflow# = raiseOverflow#++raiseDivZero# :: (#  #) -> b_reppoly+raiseDivZero# = raiseDivZero#++raiseIO# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)+raiseIO# = raiseIO#++{-| @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous+     exceptions are deferred until after evaluation has finished.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+maskAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+maskAsyncExceptions# = maskAsyncExceptions#++{-| @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous+     exceptions are deferred until after evaluation has finished.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+maskUninterruptible# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+maskUninterruptible# = maskUninterruptible#++{-| @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous+     exceptions are unmasked.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+unmaskAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+unmaskAsyncExceptions# = unmaskAsyncExceptions#++getMaskingState# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+getMaskingState# = getMaskingState#++{-| See "GHC.Prim#continuations". -}+data PromptTag# a++{-| See "GHC.Prim#continuations". -}+newPromptTag# :: State# (RealWorld) -> (# State# (RealWorld),PromptTag# a #)+newPromptTag# = newPromptTag#++{-| See "GHC.Prim#continuations". -}+prompt# :: PromptTag# a -> (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+prompt# = prompt#++{-| See "GHC.Prim#continuations". ++__/Warning:/__ this can fail with an unchecked exception.-}+control0# :: PromptTag# a -> (((State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)+control0# = control0#++data TVar# s a++atomically# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+atomically# = atomically#++retry# :: State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+retry# = retry#++catchRetry# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+catchRetry# = catchRetry#++catchSTM# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+catchSTM# = catchSTM#++{-|Create a new 'TVar#' holding a specified initial value.-}+newTVar# :: a_levpoly -> State# s -> (# State# s,TVar# s a_levpoly #)+newTVar# = newTVar#++{-|Read contents of 'TVar#' inside an STM transaction,+    i.e. within a call to 'atomically#'.+    Does not force evaluation of the result.-}+readTVar# :: TVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readTVar# = readTVar#++{-|Read contents of 'TVar#' outside an STM transaction.+   Does not force evaluation of the result.-}+readTVarIO# :: TVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readTVarIO# = readTVarIO#++{-|Write contents of 'TVar#'.-}+writeTVar# :: TVar# s a_levpoly -> a_levpoly -> State# s -> State# s+writeTVar# = writeTVar#++{-| A shared mutable variable (/not/ the same as a 'MutVar#'!).+        (Note: in a non-concurrent implementation, @('MVar#' a)@ can be+        represented by @('MutVar#' (Maybe a))@.) -}+data MVar# s a++{-|Create new 'MVar#'; initially empty.-}+newMVar# :: State# s -> (# State# s,MVar# s a_levpoly #)+newMVar# = newMVar#++{-|If 'MVar#' is empty, block until it becomes full.+   Then remove and return its contents, and set it empty.-}+takeMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+takeMVar# = takeMVar#++{-|If 'MVar#' is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.-}+tryTakeMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+tryTakeMVar# = tryTakeMVar#++{-|If 'MVar#' is full, block until it becomes empty.+   Then store value arg as its new contents.-}+putMVar# :: MVar# s a_levpoly -> a_levpoly -> State# s -> State# s+putMVar# = putMVar#++{-|If 'MVar#' is full, immediately return with integer 0.+    Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.-}+tryPutMVar# :: MVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s,Int# #)+tryPutMVar# = tryPutMVar#++{-|If 'MVar#' is empty, block until it becomes full.+   Then read its contents without modifying the MVar, without possibility+   of intervention from other threads.-}+readMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readMVar# = readMVar#++{-|If 'MVar#' is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of 'MVar#'.-}+tryReadMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+tryReadMVar# = tryReadMVar#++{-|Return 1 if 'MVar#' is empty; 0 otherwise.-}+isEmptyMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int# #)+isEmptyMVar# = isEmptyMVar#++{-|Sleep specified number of microseconds.-}+delay# :: Int# -> State# s -> State# s+delay# = delay#++{-|Block until input is available on specified file descriptor.-}+waitRead# :: Int# -> State# s -> State# s+waitRead# = waitRead#++{-|Block until output is possible on specified file descriptor.-}+waitWrite# :: Int# -> State# s -> State# s+waitWrite# = waitWrite#++{-| 'State#' is the primitive, unlifted type of states.  It has+        one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@,+        where s is a type variable. The only purpose of the type parameter+        is to keep different state threads separate.  It is represented by+        nothing at all. -}+data State# s++{-| 'RealWorld' is deeply magical.  It is /primitive/, but it is not+        /unlifted/ (hence @ptrArg@).  We never manipulate values of type+        'RealWorld'; it's only used in the type system, to parameterise 'State#'. -}+data RealWorld++{-|(In a non-concurrent implementation, this can be a singleton+        type, whose (unique) value is returned by 'myThreadId#'.  The+        other operations can be omitted.)-}+data ThreadId#++fork# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+fork# = fork#++forkOn# :: Int# -> (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+forkOn# = forkOn#++killThread# :: ThreadId# -> a -> State# (RealWorld) -> State# (RealWorld)+killThread# = killThread#++yield# :: State# (RealWorld) -> State# (RealWorld)+yield# = yield#++myThreadId# :: State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+myThreadId# = myThreadId#++{-|Set the label of the given thread. The @ByteArray#@ should contain+    a UTF-8-encoded string.-}+labelThread# :: ThreadId# -> ByteArray# -> State# (RealWorld) -> State# (RealWorld)+labelThread# = labelThread#++isCurrentThreadBound# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+isCurrentThreadBound# = isCurrentThreadBound#++noDuplicate# :: State# s -> State# s+noDuplicate# = noDuplicate#++{-|Get the label of the given thread.+    Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag+    denoting @Just@.++    @since 0.10-}+threadLabel# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int#,ByteArray# #)+threadLabel# = threadLabel#++{-|Get the status of the given thread. Result is+    @(ThreadStatus, Capability, Locked)@ where+    @ThreadStatus@ is one of the status constants defined in+    @rts/Constants.h@, @Capability@ is the number of+    the capability which currently owns the thread, and+    @Locked@ is a boolean indicating whether the+    thread is bound to that capability.++    @since 0.9-}+threadStatus# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int#,Int#,Int# #)+threadStatus# = threadStatus#++{-| Returns an array of the threads started by the program. Note that this+     threads which have finished execution may or may not be present in this+     list, depending upon whether they have been collected by the garbage collector.++     @since 0.10-}+listThreads# :: State# (RealWorld) -> (# State# (RealWorld),Array# (ThreadId#) #)+listThreads# = listThreads#++data Weak# b++{-| @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@,+     with an associated reference to some value @v@. If @k@ is still+     alive then @v@ can be retrieved using 'deRefWeak#'. Note that+     the type of @k@ must be represented by a pointer (i.e. of kind+     @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). -}+mkWeak# :: a_levpoly -> b_levpoly -> (State# (RealWorld) -> (# State# (RealWorld),c #)) -> State# (RealWorld) -> (# State# (RealWorld),Weak# b_levpoly #)+mkWeak# = mkWeak#++mkWeakNoFinalizer# :: a_levpoly -> b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Weak# b_levpoly #)+mkWeakNoFinalizer# = mkWeakNoFinalizer#++{-| @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C+     function pointer @fptr@ to a weak pointer @w@ as a finalizer. If+     @flag@ is zero, @fptr@ will be called with one argument,+     @ptr@. Otherwise, it will be called with two arguments,+     @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns+     1 on success, or 0 if @w@ is already dead. -}+addCFinalizerToWeak# :: Addr# -> Addr# -> Int# -> Addr# -> Weak# b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+addCFinalizerToWeak# = addCFinalizerToWeak#++deRefWeak# :: Weak# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int#,a_levpoly #)+deRefWeak# = deRefWeak#++{-| Finalize a weak pointer. The return value is an unboxed tuple+     containing the new state of the world and an "unboxed Maybe",+     represented by an 'Int#' and a (possibly invalid) finalization+     action. An 'Int#' of @1@ indicates that the finalizer is valid. The+     return value @b@ from the finalizer should be ignored. -}+finalizeWeak# :: Weak# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int#,State# (RealWorld) -> (# State# (RealWorld),b #) #)+finalizeWeak# = finalizeWeak#++touch# :: a_levpoly -> State# s -> State# s+touch# = touch#++data StablePtr# a++data StableName# a++makeStablePtr# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),StablePtr# a_levpoly #)+makeStablePtr# = makeStablePtr#++deRefStablePtr# :: StablePtr# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+deRefStablePtr# = deRefStablePtr#++eqStablePtr# :: StablePtr# a_levpoly -> StablePtr# a_levpoly -> Int#+eqStablePtr# = eqStablePtr#++makeStableName# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),StableName# a_levpoly #)+makeStableName# = makeStableName#++stableNameToInt# :: StableName# a_levpoly -> Int#+stableNameToInt# = stableNameToInt#++data Compact#++{-| Create a new CNF with a single compact block. The argument is+     the capacity of the compact block (in bytes, not words).+     The capacity is rounded up to a multiple of the allocator block size+     and is capped to one mega block. -}+compactNew# :: Word# -> State# (RealWorld) -> (# State# (RealWorld),Compact# #)+compactNew# = compactNew#++{-| Set the new allocation size of the CNF. This value (in bytes)+     determines the capacity of each compact block in the CNF. It+     does not retroactively affect existing compact blocks in the CNF. -}+compactResize# :: Compact# -> Word# -> State# (RealWorld) -> State# (RealWorld)+compactResize# = compactResize#++{-| Returns 1\# if the object is contained in the CNF, 0\# otherwise. -}+compactContains# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+compactContains# = compactContains#++{-| Returns 1\# if the object is in any CNF at all, 0\# otherwise. -}+compactContainsAny# :: a -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+compactContainsAny# = compactContainsAny#++{-| Returns the address and the utilized size (in bytes) of the+     first compact block of a CNF.-}+compactGetFirstBlock# :: Compact# -> State# (RealWorld) -> (# State# (RealWorld),Addr#,Word# #)+compactGetFirstBlock# = compactGetFirstBlock#++{-| Given a CNF and the address of one its compact blocks, returns the+     next compact block and its utilized size, or 'nullAddr#' if the+     argument was the last compact block in the CNF. -}+compactGetNextBlock# :: Compact# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Addr#,Word# #)+compactGetNextBlock# = compactGetNextBlock#++{-| Attempt to allocate a compact block with the capacity (in+     bytes) given by the first argument. The 'Addr#' is a pointer+     to previous compact block of the CNF or 'nullAddr#' to create a+     new CNF with a single compact block.++     The resulting block is not known to the GC until+     'compactFixupPointers#' is called on it, and care must be taken+     so that the address does not escape or memory will be leaked.+   -}+compactAllocateBlock# :: Word# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Addr# #)+compactAllocateBlock# = compactAllocateBlock#++{-| Given the pointer to the first block of a CNF and the+     address of the root object in the old address space, fix up+     the internal pointers inside the CNF to account for+     a different position in memory than when it was serialized.+     This method must be called exactly once after importing+     a serialized CNF. It returns the new CNF and the new adjusted+     root address. -}+compactFixupPointers# :: Addr# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Compact#,Addr# #)+compactFixupPointers# = compactFixupPointers#++{-| Recursively add a closure and its transitive closure to a+     'Compact#' (a CNF), evaluating any unevaluated components+     at the same time. Note: 'compactAdd#' is not thread-safe, so+     only one thread may call 'compactAdd#' with a particular+     'Compact#' at any given time. The primop does not+     enforce any mutual exclusion; the caller is expected to+     arrange this. -}+compactAdd# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),a #)+compactAdd# = compactAdd#++{-| Like 'compactAdd#', but retains sharing and cycles+   during compaction. -}+compactAddWithSharing# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),a #)+compactAddWithSharing# = compactAddWithSharing#++{-| Return the total capacity (in bytes) of all the compact blocks+     in the CNF. -}+compactSize# :: Compact# -> State# (RealWorld) -> (# State# (RealWorld),Word# #)+compactSize# = compactSize#++{-| Returns @1#@ if the given pointers are equal and @0#@ otherwise. -}+reallyUnsafePtrEquality# :: a_levpoly -> b_levpoly -> Int#+reallyUnsafePtrEquality# = reallyUnsafePtrEquality#++{-|Create a new spark evaluating the given argument.+    The return value should always be 1.+    Users are encouraged to use spark# instead.-}+par# :: a -> Int#+par# = par#++spark# :: a -> State# s -> (# State# s,a #)+spark# = spark#++getSpark# :: State# s -> (# State# s,Int#,a #)+getSpark# = getSpark#++{-| Returns the number of sparks in the local spark pool. -}+numSparks# :: State# s -> (# State# s,Int# #)+numSparks# = numSparks#++{-| @'keepAlive#' x s k@ keeps the value @x@ alive during the execution+     of the computation @k@.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. -}+keepAlive# :: a_levpoly -> State# s -> (State# s -> b_reppoly) -> b_reppoly+keepAlive# = keepAlive#++{-| Used internally to implement @dataToTag#@: Use that function instead!+     This one normally offers /no advantage/ and comes with no stability+     guarantees: it may change its type, its name, or its behavior+     with /no warning/ between compiler releases.++     It is expected that this function will be un-exposed in a future+     release of ghc.++     For more details, look at @Note [DataToTag overview]@+     in GHC.Tc.Instance.Class in the source code for+     /the specific compiler version you are using./+   -}+{-# DEPRECATED dataToTagSmall# " Use dataToTag# from \"GHC.Magic\" instead. " #-}+dataToTagSmall# :: a_levpoly -> Int#+dataToTagSmall# = dataToTagSmall#++{-| Used internally to implement @dataToTag#@: Use that function instead!+     This one offers /no advantage/ and comes with no stability+     guarantees: it may change its type, its name, or its behavior+     with /no warning/ between compiler releases.++     It is expected that this function will be un-exposed in a future+     release of ghc.++     For more details, look at @Note [DataToTag overview]@+     in GHC.Tc.Instance.Class in the source code for+     /the specific compiler version you are using./+   -}+{-# DEPRECATED dataToTagLarge# " Use dataToTag# from \"GHC.Magic\" instead. " #-}+dataToTagLarge# :: a_levpoly -> Int#+dataToTagLarge# = dataToTagLarge#++tagToEnum# :: Int# -> a+tagToEnum# = let x = x in x++{-| Primitive bytecode type. -}+data BCO++{-| Convert an 'Addr#' to a followable Any type. -}+addrToAny# :: Addr# -> (# a_levpoly #)+addrToAny# = addrToAny#++{-| Retrieve the address of any Haskell value. This is+     essentially an 'unsafeCoerce#', but if implemented as such+     the core lint pass complains and fails to compile.+     As a primop, it is opaque to core/stg, and only appears+     in cmm (where the copy propagation pass will get rid of it).+     Note that "a" must be a value, not a thunk! It's too late+     for strictness analysis to enforce this, so you're on your+     own to guarantee this. Also note that 'Addr#' is not a GC+     pointer - up to you to guarantee that it does not become+     a dangling pointer immediately after you get it.-}+anyToAddr# :: a -> State# (RealWorld) -> (# State# (RealWorld),Addr# #)+anyToAddr# = anyToAddr#++{-| Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of+     the BCO when evaluated. -}+mkApUpd0# :: BCO -> (# a #)+mkApUpd0# = mkApUpd0#++{-| @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The+     resulting object encodes a function of the given arity with the instructions+     encoded in @instrs@, and a static reference table usage bitmap given by+     @bitmap@. -}+newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s,BCO #)+newBCO# = newBCO#++{-| @'unpackClosure#' closure@ copies the closure and pointers in the+     payload of the given closure into two new arrays, and returns a pointer to+     the first word of the closure's info table, a non-pointer array for the raw+     bytes of the closure, and a pointer array for the pointers in the payload. -}+unpackClosure# :: a -> (# Addr#,ByteArray#,Array# b #)+unpackClosure# = unpackClosure#++{-| @'closureSize#' closure@ returns the size of the given closure in+     machine words. -}+closureSize# :: a -> Int#+closureSize# = closureSize#++getApStackVal# :: a -> Int# -> (# Int#,b #)+getApStackVal# = getApStackVal#++getCCSOf# :: a -> State# s -> (# State# s,Addr# #)+getCCSOf# = getCCSOf#++{-| Returns the current 'CostCentreStack' (value is @NULL@ if+     not profiling).  Takes a dummy argument which can be used to+     avoid the call to 'getCurrentCCS#' being floated out by the+     simplifier, which would result in an uninformative stack+     ("CAF"). -}+getCurrentCCS# :: a -> State# s -> (# State# s,Addr# #)+getCurrentCCS# = getCurrentCCS#++{-| Run the supplied IO action with an empty CCS.  For example, this+     is used by the interpreter to run an interpreted computation+     without the call stack showing that it was invoked from GHC. -}+clearCCS# :: (State# s -> (# State# s,a #)) -> State# s -> (# State# s,a #)+clearCCS# = clearCCS#++{-| Pushes an annotation frame to the stack which can be reported by backtraces. -}+annotateStack# :: b -> (State# s -> (# State# s,a_reppoly #)) -> State# s -> (# State# s,a_reppoly #)+annotateStack# = annotateStack#++{-| Fills the given buffer with the @InfoProvEnt@ for the info table of the+     given object. Returns @1#@ on success and @0#@ otherwise.-}+whereFrom# :: a -> Addr# -> State# s -> (# State# s,Int# #)+whereFrom# = whereFrom#++{-|The builtin function type, written in infix form as @a % m -> b@.+   Values of this type are functions taking inputs of type @a@ and+   producing outputs of type @b@. The multiplicity of the input is+   @m@.++   Note that @'FUN' m a b@ permits representation polymorphism in both+   @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be+   well-kinded.+  -}+data FUN m a b++{-| The token used in the implementation of the IO monad as a state monad.+     It does not pass any information at runtime.+     See also 'GHC.Magic.runRW#'. -}+realWorld# :: State# (RealWorld)+realWorld# = realWorld#++{-| This is an alias for the unboxed unit tuple constructor.+     In earlier versions of GHC, 'void#' was a value+     of the primitive type 'Void#', which is now defined to be @(# #)@.+   -}+{-# DEPRECATED void# " Use an unboxed unit tuple instead " #-}+void# :: (#  #)+void# = void#++{-| The type constructor 'Proxy#' is used to bear witness to some+   type variable. It's used when you want to pass around proxy values+   for doing things like modelling type applications. A 'Proxy#'+   is not only unboxed, it also has a polymorphic kind, and has no+   runtime representation, being totally free. -}+data Proxy# a++{-| Witness for an unboxed 'Proxy#' value, which has no runtime+   representation. -}+proxy# :: Proxy# a+proxy# = proxy#++{-| The value of @'seq' a b@ is bottom if @a@ is bottom, and+     otherwise equal to @b@. In other words, it evaluates the first+     argument @a@ to weak head normal form (WHNF). 'seq' is usually+     introduced to improve performance by avoiding unneeded laziness.++     A note on evaluation order: the expression @'seq' a b@ does+     /not/ guarantee that @a@ will be evaluated before @b@.+     The only guarantee given by 'seq' is that the both @a@+     and @b@ will be evaluated before 'seq' returns a value.+     In particular, this means that @b@ may be evaluated before+     @a@. If you need to guarantee a specific order of evaluation,+     you must use the function 'pseq' from the "parallel" package. -}+infixr 0 `seq`+seq :: a -> b_reppoly -> b_reppoly+seq = seq++{-| Emits an event via the RTS tracing framework.  The contents+     of the event is the zero-terminated byte string passed as the first+     argument.  The event will be emitted either to the @.eventlog@ file,+     or to stderr, depending on the runtime RTS flags. -}+traceEvent# :: Addr# -> State# s -> State# s+traceEvent# = traceEvent#++{-| Emits an event via the RTS tracing framework.  The contents+     of the event is the binary object passed as the first argument with+     the given length passed as the second argument. The event will be+     emitted to the @.eventlog@ file. -}+traceBinaryEvent# :: Addr# -> Int# -> State# s -> State# s+traceBinaryEvent# = traceBinaryEvent#++{-| Emits a marker event via the RTS tracing framework.  The contents+     of the event is the zero-terminated byte string passed as the first+     argument.  The event will be emitted either to the @.eventlog@ file,+     or to stderr, depending on the runtime RTS flags. -}+traceMarker# :: Addr# -> State# s -> State# s+traceMarker# = traceMarker#++{-| Sets the allocation counter for the current thread to the given value. -}+setThreadAllocationCounter# :: Int64# -> State# (RealWorld) -> State# (RealWorld)+setThreadAllocationCounter# = setThreadAllocationCounter#++{-| Sets the allocation counter for the another thread to the given value.+     This doesn't take allocations into the current nursery chunk into account.+     Therefore it is only accurate if the other thread is not currently running. -}+setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# (RealWorld) -> State# (RealWorld)+setOtherThreadAllocationCounter# = setOtherThreadAllocationCounter#++{-| Haskell representation of a @StgStack*@ that was created (cloned)+     with a function in "GHC.Stack.CloneStack". Please check the+     documentation in that module for more detailed explanations. -}+data StackSnapshot#++{-| The function 'coerce' allows you to safely convert between values of+     types that have the same representation with no run-time overhead. In the+     simplest case you can use it instead of a newtype constructor, to go from+     the newtype's concrete type to the abstract type. But it also works in+     more complicated settings, e.g. converting a list of newtypes to a list of+     concrete types.++     When used in conversions involving a newtype wrapper,+     make sure the newtype constructor is in scope.++     This function is representation-polymorphic, but the+     'RuntimeRep' type argument is marked as 'Inferred', meaning+     that it is not available for visible type application. This means+     the typechecker will accept @'coerce' \@'Int' \@Age 42@.++     === __Examples__++     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)+     >>> newtype Age = Age Int deriving (Eq, Ord, Show)+     >>> coerce (Age 42) :: TTL+     TTL 42+     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL+     TTL 43+     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]+     [TTL 43,TTL 25]++   -}+coerce :: Coercible a b => a -> b+coerce = coerce++data Int8X16#++data Int16X8#++data Int32X4#++data Int64X2#++data Int8X32#++data Int16X16#++data Int32X8#++data Int64X4#++data Int8X64#++data Int16X32#++data Int32X16#++data Int64X8#++data Word8X16#++data Word16X8#++data Word32X4#++data Word64X2#++data Word8X32#++data Word16X16#++data Word32X8#++data Word64X4#++data Word8X64#++data Word16X32#++data Word32X16#++data Word64X8#++data FloatX4#++data DoubleX2#++data FloatX8#++data DoubleX4#++data FloatX16#++data DoubleX8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt8X16# :: Int8# -> Int8X16#+broadcastInt8X16# = broadcastInt8X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt16X8# :: Int16# -> Int16X8#+broadcastInt16X8# = broadcastInt16X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt32X4# :: Int32# -> Int32X4#+broadcastInt32X4# = broadcastInt32X4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt64X2# :: Int64# -> Int64X2#+broadcastInt64X2# = broadcastInt64X2#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt8X32# :: Int8# -> Int8X32#+broadcastInt8X32# = broadcastInt8X32#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt16X16# :: Int16# -> Int16X16#+broadcastInt16X16# = broadcastInt16X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt32X8# :: Int32# -> Int32X8#+broadcastInt32X8# = broadcastInt32X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt64X4# :: Int64# -> Int64X4#+broadcastInt64X4# = broadcastInt64X4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt8X64# :: Int8# -> Int8X64#+broadcastInt8X64# = broadcastInt8X64#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt16X32# :: Int16# -> Int16X32#+broadcastInt16X32# = broadcastInt16X32#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt32X16# :: Int32# -> Int32X16#+broadcastInt32X16# = broadcastInt32X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastInt64X8# :: Int64# -> Int64X8#+broadcastInt64X8# = broadcastInt64X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord8X16# :: Word8# -> Word8X16#+broadcastWord8X16# = broadcastWord8X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord16X8# :: Word16# -> Word16X8#+broadcastWord16X8# = broadcastWord16X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord32X4# :: Word32# -> Word32X4#+broadcastWord32X4# = broadcastWord32X4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord64X2# :: Word64# -> Word64X2#+broadcastWord64X2# = broadcastWord64X2#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord8X32# :: Word8# -> Word8X32#+broadcastWord8X32# = broadcastWord8X32#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord16X16# :: Word16# -> Word16X16#+broadcastWord16X16# = broadcastWord16X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord32X8# :: Word32# -> Word32X8#+broadcastWord32X8# = broadcastWord32X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord64X4# :: Word64# -> Word64X4#+broadcastWord64X4# = broadcastWord64X4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord8X64# :: Word8# -> Word8X64#+broadcastWord8X64# = broadcastWord8X64#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord16X32# :: Word16# -> Word16X32#+broadcastWord16X32# = broadcastWord16X32#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord32X16# :: Word32# -> Word32X16#+broadcastWord32X16# = broadcastWord32X16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastWord64X8# :: Word64# -> Word64X8#+broadcastWord64X8# = broadcastWord64X8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastFloatX4# :: Float# -> FloatX4#+broadcastFloatX4# = broadcastFloatX4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastDoubleX2# :: Double# -> DoubleX2#+broadcastDoubleX2# = broadcastDoubleX2#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastFloatX8# :: Float# -> FloatX8#+broadcastFloatX8# = broadcastFloatX8#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastDoubleX4# :: Double# -> DoubleX4#+broadcastDoubleX4# = broadcastDoubleX4#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastFloatX16# :: Float# -> FloatX16#+broadcastFloatX16# = broadcastFloatX16#++{-| Broadcast a scalar to all elements of a vector. -}+broadcastDoubleX8# :: Double# -> DoubleX8#+broadcastDoubleX8# = broadcastDoubleX8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt8X16# :: (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #) -> Int8X16#+packInt8X16# = packInt8X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt16X8# :: (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #) -> Int16X8#+packInt16X8# = packInt16X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt32X4# :: (# Int32#,Int32#,Int32#,Int32# #) -> Int32X4#+packInt32X4# = packInt32X4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt64X2# :: (# Int64#,Int64# #) -> Int64X2#+packInt64X2# = packInt64X2#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt8X32# :: (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #) -> Int8X32#+packInt8X32# = packInt8X32#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt16X16# :: (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #) -> Int16X16#+packInt16X16# = packInt16X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt32X8# :: (# Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32# #) -> Int32X8#+packInt32X8# = packInt32X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt64X4# :: (# Int64#,Int64#,Int64#,Int64# #) -> Int64X4#+packInt64X4# = packInt64X4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt8X64# :: (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #) -> Int8X64#+packInt8X64# = packInt8X64#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt16X32# :: (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #) -> Int16X32#+packInt16X32# = packInt16X32#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt32X16# :: (# Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32# #) -> Int32X16#+packInt32X16# = packInt32X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packInt64X8# :: (# Int64#,Int64#,Int64#,Int64#,Int64#,Int64#,Int64#,Int64# #) -> Int64X8#+packInt64X8# = packInt64X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord8X16# :: (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #) -> Word8X16#+packWord8X16# = packWord8X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord16X8# :: (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #) -> Word16X8#+packWord16X8# = packWord16X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord32X4# :: (# Word32#,Word32#,Word32#,Word32# #) -> Word32X4#+packWord32X4# = packWord32X4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord64X2# :: (# Word64#,Word64# #) -> Word64X2#+packWord64X2# = packWord64X2#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord8X32# :: (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #) -> Word8X32#+packWord8X32# = packWord8X32#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord16X16# :: (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #) -> Word16X16#+packWord16X16# = packWord16X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord32X8# :: (# Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32# #) -> Word32X8#+packWord32X8# = packWord32X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord64X4# :: (# Word64#,Word64#,Word64#,Word64# #) -> Word64X4#+packWord64X4# = packWord64X4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord8X64# :: (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #) -> Word8X64#+packWord8X64# = packWord8X64#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord16X32# :: (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #) -> Word16X32#+packWord16X32# = packWord16X32#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord32X16# :: (# Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32# #) -> Word32X16#+packWord32X16# = packWord32X16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packWord64X8# :: (# Word64#,Word64#,Word64#,Word64#,Word64#,Word64#,Word64#,Word64# #) -> Word64X8#+packWord64X8# = packWord64X8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packFloatX4# :: (# Float#,Float#,Float#,Float# #) -> FloatX4#+packFloatX4# = packFloatX4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packDoubleX2# :: (# Double#,Double# #) -> DoubleX2#+packDoubleX2# = packDoubleX2#++{-| Pack the elements of an unboxed tuple into a vector. -}+packFloatX8# :: (# Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float# #) -> FloatX8#+packFloatX8# = packFloatX8#++{-| Pack the elements of an unboxed tuple into a vector. -}+packDoubleX4# :: (# Double#,Double#,Double#,Double# #) -> DoubleX4#+packDoubleX4# = packDoubleX4#++{-| Pack the elements of an unboxed tuple into a vector. -}+packFloatX16# :: (# Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float# #) -> FloatX16#+packFloatX16# = packFloatX16#++{-| Pack the elements of an unboxed tuple into a vector. -}+packDoubleX8# :: (# Double#,Double#,Double#,Double#,Double#,Double#,Double#,Double# #) -> DoubleX8#+packDoubleX8# = packDoubleX8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt8X16# :: Int8X16# -> (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #)+unpackInt8X16# = unpackInt8X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt16X8# :: Int16X8# -> (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #)+unpackInt16X8# = unpackInt16X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt32X4# :: Int32X4# -> (# Int32#,Int32#,Int32#,Int32# #)+unpackInt32X4# = unpackInt32X4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt64X2# :: Int64X2# -> (# Int64#,Int64# #)+unpackInt64X2# = unpackInt64X2#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt8X32# :: Int8X32# -> (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #)+unpackInt8X32# = unpackInt8X32#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt16X16# :: Int16X16# -> (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #)+unpackInt16X16# = unpackInt16X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt32X8# :: Int32X8# -> (# Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32# #)+unpackInt32X8# = unpackInt32X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt64X4# :: Int64X4# -> (# Int64#,Int64#,Int64#,Int64# #)+unpackInt64X4# = unpackInt64X4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt8X64# :: Int8X64# -> (# Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8#,Int8# #)+unpackInt8X64# = unpackInt8X64#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt16X32# :: Int16X32# -> (# Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16#,Int16# #)+unpackInt16X32# = unpackInt16X32#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt32X16# :: Int32X16# -> (# Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32#,Int32# #)+unpackInt32X16# = unpackInt32X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackInt64X8# :: Int64X8# -> (# Int64#,Int64#,Int64#,Int64#,Int64#,Int64#,Int64#,Int64# #)+unpackInt64X8# = unpackInt64X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord8X16# :: Word8X16# -> (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #)+unpackWord8X16# = unpackWord8X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord16X8# :: Word16X8# -> (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #)+unpackWord16X8# = unpackWord16X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord32X4# :: Word32X4# -> (# Word32#,Word32#,Word32#,Word32# #)+unpackWord32X4# = unpackWord32X4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord64X2# :: Word64X2# -> (# Word64#,Word64# #)+unpackWord64X2# = unpackWord64X2#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord8X32# :: Word8X32# -> (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #)+unpackWord8X32# = unpackWord8X32#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord16X16# :: Word16X16# -> (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #)+unpackWord16X16# = unpackWord16X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord32X8# :: Word32X8# -> (# Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32# #)+unpackWord32X8# = unpackWord32X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord64X4# :: Word64X4# -> (# Word64#,Word64#,Word64#,Word64# #)+unpackWord64X4# = unpackWord64X4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord8X64# :: Word8X64# -> (# Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8#,Word8# #)+unpackWord8X64# = unpackWord8X64#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord16X32# :: Word16X32# -> (# Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16#,Word16# #)+unpackWord16X32# = unpackWord16X32#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord32X16# :: Word32X16# -> (# Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32#,Word32# #)+unpackWord32X16# = unpackWord32X16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackWord64X8# :: Word64X8# -> (# Word64#,Word64#,Word64#,Word64#,Word64#,Word64#,Word64#,Word64# #)+unpackWord64X8# = unpackWord64X8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackFloatX4# :: FloatX4# -> (# Float#,Float#,Float#,Float# #)+unpackFloatX4# = unpackFloatX4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackDoubleX2# :: DoubleX2# -> (# Double#,Double# #)+unpackDoubleX2# = unpackDoubleX2#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackFloatX8# :: FloatX8# -> (# Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float# #)+unpackFloatX8# = unpackFloatX8#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackDoubleX4# :: DoubleX4# -> (# Double#,Double#,Double#,Double# #)+unpackDoubleX4# = unpackDoubleX4#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackFloatX16# :: FloatX16# -> (# Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float#,Float# #)+unpackFloatX16# = unpackFloatX16#++{-| Unpack the elements of a vector into an unboxed tuple. -}+unpackDoubleX8# :: DoubleX8# -> (# Double#,Double#,Double#,Double#,Double#,Double#,Double#,Double# #)+unpackDoubleX8# = unpackDoubleX8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt8X16# :: Int8X16# -> Int8# -> Int# -> Int8X16#+insertInt8X16# = insertInt8X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt16X8# :: Int16X8# -> Int16# -> Int# -> Int16X8#+insertInt16X8# = insertInt16X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt32X4# :: Int32X4# -> Int32# -> Int# -> Int32X4#+insertInt32X4# = insertInt32X4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt64X2# :: Int64X2# -> Int64# -> Int# -> Int64X2#+insertInt64X2# = insertInt64X2#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt8X32# :: Int8X32# -> Int8# -> Int# -> Int8X32#+insertInt8X32# = insertInt8X32#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt16X16# :: Int16X16# -> Int16# -> Int# -> Int16X16#+insertInt16X16# = insertInt16X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt32X8# :: Int32X8# -> Int32# -> Int# -> Int32X8#+insertInt32X8# = insertInt32X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt64X4# :: Int64X4# -> Int64# -> Int# -> Int64X4#+insertInt64X4# = insertInt64X4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt8X64# :: Int8X64# -> Int8# -> Int# -> Int8X64#+insertInt8X64# = insertInt8X64#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt16X32# :: Int16X32# -> Int16# -> Int# -> Int16X32#+insertInt16X32# = insertInt16X32#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt32X16# :: Int32X16# -> Int32# -> Int# -> Int32X16#+insertInt32X16# = insertInt32X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertInt64X8# :: Int64X8# -> Int64# -> Int# -> Int64X8#+insertInt64X8# = insertInt64X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord8X16# :: Word8X16# -> Word8# -> Int# -> Word8X16#+insertWord8X16# = insertWord8X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord16X8# :: Word16X8# -> Word16# -> Int# -> Word16X8#+insertWord16X8# = insertWord16X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord32X4# :: Word32X4# -> Word32# -> Int# -> Word32X4#+insertWord32X4# = insertWord32X4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord64X2# :: Word64X2# -> Word64# -> Int# -> Word64X2#+insertWord64X2# = insertWord64X2#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord8X32# :: Word8X32# -> Word8# -> Int# -> Word8X32#+insertWord8X32# = insertWord8X32#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord16X16# :: Word16X16# -> Word16# -> Int# -> Word16X16#+insertWord16X16# = insertWord16X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord32X8# :: Word32X8# -> Word32# -> Int# -> Word32X8#+insertWord32X8# = insertWord32X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord64X4# :: Word64X4# -> Word64# -> Int# -> Word64X4#+insertWord64X4# = insertWord64X4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord8X64# :: Word8X64# -> Word8# -> Int# -> Word8X64#+insertWord8X64# = insertWord8X64#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord16X32# :: Word16X32# -> Word16# -> Int# -> Word16X32#+insertWord16X32# = insertWord16X32#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord32X16# :: Word32X16# -> Word32# -> Int# -> Word32X16#+insertWord32X16# = insertWord32X16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertWord64X8# :: Word64X8# -> Word64# -> Int# -> Word64X8#+insertWord64X8# = insertWord64X8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertFloatX4# :: FloatX4# -> Float# -> Int# -> FloatX4#+insertFloatX4# = insertFloatX4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertDoubleX2# :: DoubleX2# -> Double# -> Int# -> DoubleX2#+insertDoubleX2# = insertDoubleX2#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertFloatX8# :: FloatX8# -> Float# -> Int# -> FloatX8#+insertFloatX8# = insertFloatX8#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertDoubleX4# :: DoubleX4# -> Double# -> Int# -> DoubleX4#+insertDoubleX4# = insertDoubleX4#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertFloatX16# :: FloatX16# -> Float# -> Int# -> FloatX16#+insertFloatX16# = insertFloatX16#++{-| Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. -}+insertDoubleX8# :: DoubleX8# -> Double# -> Int# -> DoubleX8#+insertDoubleX8# = insertDoubleX8#++{-| Add two vectors element-wise. -}+plusInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+plusInt8X16# = plusInt8X16#++{-| Add two vectors element-wise. -}+plusInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+plusInt16X8# = plusInt16X8#++{-| Add two vectors element-wise. -}+plusInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+plusInt32X4# = plusInt32X4#++{-| Add two vectors element-wise. -}+plusInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+plusInt64X2# = plusInt64X2#++{-| Add two vectors element-wise. -}+plusInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+plusInt8X32# = plusInt8X32#++{-| Add two vectors element-wise. -}+plusInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+plusInt16X16# = plusInt16X16#++{-| Add two vectors element-wise. -}+plusInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+plusInt32X8# = plusInt32X8#++{-| Add two vectors element-wise. -}+plusInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+plusInt64X4# = plusInt64X4#++{-| Add two vectors element-wise. -}+plusInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+plusInt8X64# = plusInt8X64#++{-| Add two vectors element-wise. -}+plusInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+plusInt16X32# = plusInt16X32#++{-| Add two vectors element-wise. -}+plusInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+plusInt32X16# = plusInt32X16#++{-| Add two vectors element-wise. -}+plusInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+plusInt64X8# = plusInt64X8#++{-| Add two vectors element-wise. -}+plusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+plusWord8X16# = plusWord8X16#++{-| Add two vectors element-wise. -}+plusWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+plusWord16X8# = plusWord16X8#++{-| Add two vectors element-wise. -}+plusWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+plusWord32X4# = plusWord32X4#++{-| Add two vectors element-wise. -}+plusWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+plusWord64X2# = plusWord64X2#++{-| Add two vectors element-wise. -}+plusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+plusWord8X32# = plusWord8X32#++{-| Add two vectors element-wise. -}+plusWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+plusWord16X16# = plusWord16X16#++{-| Add two vectors element-wise. -}+plusWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+plusWord32X8# = plusWord32X8#++{-| Add two vectors element-wise. -}+plusWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+plusWord64X4# = plusWord64X4#++{-| Add two vectors element-wise. -}+plusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+plusWord8X64# = plusWord8X64#++{-| Add two vectors element-wise. -}+plusWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+plusWord16X32# = plusWord16X32#++{-| Add two vectors element-wise. -}+plusWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+plusWord32X16# = plusWord32X16#++{-| Add two vectors element-wise. -}+plusWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+plusWord64X8# = plusWord64X8#++{-| Add two vectors element-wise. -}+plusFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+plusFloatX4# = plusFloatX4#++{-| Add two vectors element-wise. -}+plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+plusDoubleX2# = plusDoubleX2#++{-| Add two vectors element-wise. -}+plusFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+plusFloatX8# = plusFloatX8#++{-| Add two vectors element-wise. -}+plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+plusDoubleX4# = plusDoubleX4#++{-| Add two vectors element-wise. -}+plusFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+plusFloatX16# = plusFloatX16#++{-| Add two vectors element-wise. -}+plusDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+plusDoubleX8# = plusDoubleX8#++{-| Subtract two vectors element-wise. -}+minusInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+minusInt8X16# = minusInt8X16#++{-| Subtract two vectors element-wise. -}+minusInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+minusInt16X8# = minusInt16X8#++{-| Subtract two vectors element-wise. -}+minusInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+minusInt32X4# = minusInt32X4#++{-| Subtract two vectors element-wise. -}+minusInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+minusInt64X2# = minusInt64X2#++{-| Subtract two vectors element-wise. -}+minusInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+minusInt8X32# = minusInt8X32#++{-| Subtract two vectors element-wise. -}+minusInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+minusInt16X16# = minusInt16X16#++{-| Subtract two vectors element-wise. -}+minusInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+minusInt32X8# = minusInt32X8#++{-| Subtract two vectors element-wise. -}+minusInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+minusInt64X4# = minusInt64X4#++{-| Subtract two vectors element-wise. -}+minusInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+minusInt8X64# = minusInt8X64#++{-| Subtract two vectors element-wise. -}+minusInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+minusInt16X32# = minusInt16X32#++{-| Subtract two vectors element-wise. -}+minusInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+minusInt32X16# = minusInt32X16#++{-| Subtract two vectors element-wise. -}+minusInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+minusInt64X8# = minusInt64X8#++{-| Subtract two vectors element-wise. -}+minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+minusWord8X16# = minusWord8X16#++{-| Subtract two vectors element-wise. -}+minusWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+minusWord16X8# = minusWord16X8#++{-| Subtract two vectors element-wise. -}+minusWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+minusWord32X4# = minusWord32X4#++{-| Subtract two vectors element-wise. -}+minusWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+minusWord64X2# = minusWord64X2#++{-| Subtract two vectors element-wise. -}+minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+minusWord8X32# = minusWord8X32#++{-| Subtract two vectors element-wise. -}+minusWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+minusWord16X16# = minusWord16X16#++{-| Subtract two vectors element-wise. -}+minusWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+minusWord32X8# = minusWord32X8#++{-| Subtract two vectors element-wise. -}+minusWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+minusWord64X4# = minusWord64X4#++{-| Subtract two vectors element-wise. -}+minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+minusWord8X64# = minusWord8X64#++{-| Subtract two vectors element-wise. -}+minusWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+minusWord16X32# = minusWord16X32#++{-| Subtract two vectors element-wise. -}+minusWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+minusWord32X16# = minusWord32X16#++{-| Subtract two vectors element-wise. -}+minusWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+minusWord64X8# = minusWord64X8#++{-| Subtract two vectors element-wise. -}+minusFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+minusFloatX4# = minusFloatX4#++{-| Subtract two vectors element-wise. -}+minusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+minusDoubleX2# = minusDoubleX2#++{-| Subtract two vectors element-wise. -}+minusFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+minusFloatX8# = minusFloatX8#++{-| Subtract two vectors element-wise. -}+minusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+minusDoubleX4# = minusDoubleX4#++{-| Subtract two vectors element-wise. -}+minusFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+minusFloatX16# = minusFloatX16#++{-| Subtract two vectors element-wise. -}+minusDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+minusDoubleX8# = minusDoubleX8#++{-| Multiply two vectors element-wise. -}+timesInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+timesInt8X16# = timesInt8X16#++{-| Multiply two vectors element-wise. -}+timesInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+timesInt16X8# = timesInt16X8#++{-| Multiply two vectors element-wise. -}+timesInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+timesInt32X4# = timesInt32X4#++{-| Multiply two vectors element-wise. -}+timesInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+timesInt64X2# = timesInt64X2#++{-| Multiply two vectors element-wise. -}+timesInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+timesInt8X32# = timesInt8X32#++{-| Multiply two vectors element-wise. -}+timesInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+timesInt16X16# = timesInt16X16#++{-| Multiply two vectors element-wise. -}+timesInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+timesInt32X8# = timesInt32X8#++{-| Multiply two vectors element-wise. -}+timesInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+timesInt64X4# = timesInt64X4#++{-| Multiply two vectors element-wise. -}+timesInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+timesInt8X64# = timesInt8X64#++{-| Multiply two vectors element-wise. -}+timesInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+timesInt16X32# = timesInt16X32#++{-| Multiply two vectors element-wise. -}+timesInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+timesInt32X16# = timesInt32X16#++{-| Multiply two vectors element-wise. -}+timesInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+timesInt64X8# = timesInt64X8#++{-| Multiply two vectors element-wise. -}+timesWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+timesWord8X16# = timesWord8X16#++{-| Multiply two vectors element-wise. -}+timesWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+timesWord16X8# = timesWord16X8#++{-| Multiply two vectors element-wise. -}+timesWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+timesWord32X4# = timesWord32X4#++{-| Multiply two vectors element-wise. -}+timesWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+timesWord64X2# = timesWord64X2#++{-| Multiply two vectors element-wise. -}+timesWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+timesWord8X32# = timesWord8X32#++{-| Multiply two vectors element-wise. -}+timesWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+timesWord16X16# = timesWord16X16#++{-| Multiply two vectors element-wise. -}+timesWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+timesWord32X8# = timesWord32X8#++{-| Multiply two vectors element-wise. -}+timesWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+timesWord64X4# = timesWord64X4#++{-| Multiply two vectors element-wise. -}+timesWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+timesWord8X64# = timesWord8X64#++{-| Multiply two vectors element-wise. -}+timesWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+timesWord16X32# = timesWord16X32#++{-| Multiply two vectors element-wise. -}+timesWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+timesWord32X16# = timesWord32X16#++{-| Multiply two vectors element-wise. -}+timesWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+timesWord64X8# = timesWord64X8#++{-| Multiply two vectors element-wise. -}+timesFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+timesFloatX4# = timesFloatX4#++{-| Multiply two vectors element-wise. -}+timesDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+timesDoubleX2# = timesDoubleX2#++{-| Multiply two vectors element-wise. -}+timesFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+timesFloatX8# = timesFloatX8#++{-| Multiply two vectors element-wise. -}+timesDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+timesDoubleX4# = timesDoubleX4#++{-| Multiply two vectors element-wise. -}+timesFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+timesFloatX16# = timesFloatX16#++{-| Multiply two vectors element-wise. -}+timesDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+timesDoubleX8# = timesDoubleX8#++{-| Divide two vectors element-wise. -}+divideFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+divideFloatX4# = divideFloatX4#++{-| Divide two vectors element-wise. -}+divideDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+divideDoubleX2# = divideDoubleX2#++{-| Divide two vectors element-wise. -}+divideFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+divideFloatX8# = divideFloatX8#++{-| Divide two vectors element-wise. -}+divideDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+divideDoubleX4# = divideDoubleX4#++{-| Divide two vectors element-wise. -}+divideFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+divideFloatX16# = divideFloatX16#++{-| Divide two vectors element-wise. -}+divideDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+divideDoubleX8# = divideDoubleX8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+quotInt8X16# = quotInt8X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+quotInt16X8# = quotInt16X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+quotInt32X4# = quotInt32X4#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+quotInt64X2# = quotInt64X2#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+quotInt8X32# = quotInt8X32#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+quotInt16X16# = quotInt16X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+quotInt32X8# = quotInt32X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+quotInt64X4# = quotInt64X4#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+quotInt8X64# = quotInt8X64#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+quotInt16X32# = quotInt16X32#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+quotInt32X16# = quotInt32X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+quotInt64X8# = quotInt64X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+quotWord8X16# = quotWord8X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+quotWord16X8# = quotWord16X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+quotWord32X4# = quotWord32X4#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+quotWord64X2# = quotWord64X2#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+quotWord8X32# = quotWord8X32#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+quotWord16X16# = quotWord16X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+quotWord32X8# = quotWord32X8#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+quotWord64X4# = quotWord64X4#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+quotWord8X64# = quotWord8X64#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+quotWord16X32# = quotWord16X32#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+quotWord32X16# = quotWord32X16#++{-| Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+quotWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+quotWord64X8# = quotWord64X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+remInt8X16# = remInt8X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+remInt16X8# = remInt16X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+remInt32X4# = remInt32X4#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+remInt64X2# = remInt64X2#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+remInt8X32# = remInt8X32#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+remInt16X16# = remInt16X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+remInt32X8# = remInt32X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+remInt64X4# = remInt64X4#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+remInt8X64# = remInt8X64#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+remInt16X32# = remInt16X32#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+remInt32X16# = remInt32X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+remInt64X8# = remInt64X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+remWord8X16# = remWord8X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+remWord16X8# = remWord16X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+remWord32X4# = remWord32X4#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+remWord64X2# = remWord64X2#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+remWord8X32# = remWord8X32#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+remWord16X16# = remWord16X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+remWord32X8# = remWord32X8#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+remWord64X4# = remWord64X4#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+remWord8X64# = remWord8X64#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+remWord16X32# = remWord16X32#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+remWord32X16# = remWord32X16#++{-| Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. -}+remWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+remWord64X8# = remWord64X8#++{-| Negate element-wise. -}+negateInt8X16# :: Int8X16# -> Int8X16#+negateInt8X16# = negateInt8X16#++{-| Negate element-wise. -}+negateInt16X8# :: Int16X8# -> Int16X8#+negateInt16X8# = negateInt16X8#++{-| Negate element-wise. -}+negateInt32X4# :: Int32X4# -> Int32X4#+negateInt32X4# = negateInt32X4#++{-| Negate element-wise. -}+negateInt64X2# :: Int64X2# -> Int64X2#+negateInt64X2# = negateInt64X2#++{-| Negate element-wise. -}+negateInt8X32# :: Int8X32# -> Int8X32#+negateInt8X32# = negateInt8X32#++{-| Negate element-wise. -}+negateInt16X16# :: Int16X16# -> Int16X16#+negateInt16X16# = negateInt16X16#++{-| Negate element-wise. -}+negateInt32X8# :: Int32X8# -> Int32X8#+negateInt32X8# = negateInt32X8#++{-| Negate element-wise. -}+negateInt64X4# :: Int64X4# -> Int64X4#+negateInt64X4# = negateInt64X4#++{-| Negate element-wise. -}+negateInt8X64# :: Int8X64# -> Int8X64#+negateInt8X64# = negateInt8X64#++{-| Negate element-wise. -}+negateInt16X32# :: Int16X32# -> Int16X32#+negateInt16X32# = negateInt16X32#++{-| Negate element-wise. -}+negateInt32X16# :: Int32X16# -> Int32X16#+negateInt32X16# = negateInt32X16#++{-| Negate element-wise. -}+negateInt64X8# :: Int64X8# -> Int64X8#+negateInt64X8# = negateInt64X8#++{-| Negate element-wise. -}+negateFloatX4# :: FloatX4# -> FloatX4#+negateFloatX4# = negateFloatX4#++{-| Negate element-wise. -}+negateDoubleX2# :: DoubleX2# -> DoubleX2#+negateDoubleX2# = negateDoubleX2#++{-| Negate element-wise. -}+negateFloatX8# :: FloatX8# -> FloatX8#+negateFloatX8# = negateFloatX8#++{-| Negate element-wise. -}+negateDoubleX4# :: DoubleX4# -> DoubleX4#+negateDoubleX4# = negateDoubleX4#++{-| Negate element-wise. -}+negateFloatX16# :: FloatX16# -> FloatX16#+negateFloatX16# = negateFloatX16#++{-| Negate element-wise. -}+negateDoubleX8# :: DoubleX8# -> DoubleX8#+negateDoubleX8# = negateDoubleX8#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt8X16Array# :: ByteArray# -> Int# -> Int8X16#+indexInt8X16Array# = indexInt8X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt16X8Array# :: ByteArray# -> Int# -> Int16X8#+indexInt16X8Array# = indexInt16X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt32X4Array# :: ByteArray# -> Int# -> Int32X4#+indexInt32X4Array# = indexInt32X4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt64X2Array# :: ByteArray# -> Int# -> Int64X2#+indexInt64X2Array# = indexInt64X2Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt8X32Array# :: ByteArray# -> Int# -> Int8X32#+indexInt8X32Array# = indexInt8X32Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt16X16Array# :: ByteArray# -> Int# -> Int16X16#+indexInt16X16Array# = indexInt16X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt32X8Array# :: ByteArray# -> Int# -> Int32X8#+indexInt32X8Array# = indexInt32X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt64X4Array# :: ByteArray# -> Int# -> Int64X4#+indexInt64X4Array# = indexInt64X4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt8X64Array# :: ByteArray# -> Int# -> Int8X64#+indexInt8X64Array# = indexInt8X64Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt16X32Array# :: ByteArray# -> Int# -> Int16X32#+indexInt16X32Array# = indexInt16X32Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt32X16Array# :: ByteArray# -> Int# -> Int32X16#+indexInt32X16Array# = indexInt32X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexInt64X8Array# :: ByteArray# -> Int# -> Int64X8#+indexInt64X8Array# = indexInt64X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord8X16Array# :: ByteArray# -> Int# -> Word8X16#+indexWord8X16Array# = indexWord8X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord16X8Array# :: ByteArray# -> Int# -> Word16X8#+indexWord16X8Array# = indexWord16X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord32X4Array# :: ByteArray# -> Int# -> Word32X4#+indexWord32X4Array# = indexWord32X4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord64X2Array# :: ByteArray# -> Int# -> Word64X2#+indexWord64X2Array# = indexWord64X2Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord8X32Array# :: ByteArray# -> Int# -> Word8X32#+indexWord8X32Array# = indexWord8X32Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord16X16Array# :: ByteArray# -> Int# -> Word16X16#+indexWord16X16Array# = indexWord16X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord32X8Array# :: ByteArray# -> Int# -> Word32X8#+indexWord32X8Array# = indexWord32X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord64X4Array# :: ByteArray# -> Int# -> Word64X4#+indexWord64X4Array# = indexWord64X4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord8X64Array# :: ByteArray# -> Int# -> Word8X64#+indexWord8X64Array# = indexWord8X64Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord16X32Array# :: ByteArray# -> Int# -> Word16X32#+indexWord16X32Array# = indexWord16X32Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord32X16Array# :: ByteArray# -> Int# -> Word32X16#+indexWord32X16Array# = indexWord32X16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexWord64X8Array# :: ByteArray# -> Int# -> Word64X8#+indexWord64X8Array# = indexWord64X8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexFloatX4Array# :: ByteArray# -> Int# -> FloatX4#+indexFloatX4Array# = indexFloatX4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexDoubleX2Array# :: ByteArray# -> Int# -> DoubleX2#+indexDoubleX2Array# = indexDoubleX2Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexFloatX8Array# :: ByteArray# -> Int# -> FloatX8#+indexFloatX8Array# = indexFloatX8Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexDoubleX4Array# :: ByteArray# -> Int# -> DoubleX4#+indexDoubleX4Array# = indexDoubleX4Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexFloatX16Array# :: ByteArray# -> Int# -> FloatX16#+indexFloatX16Array# = indexFloatX16Array#++{-| Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). -}+indexDoubleX8Array# :: ByteArray# -> Int# -> DoubleX8#+indexDoubleX8Array# = indexDoubleX8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X16# #)+readInt8X16Array# = readInt8X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X8# #)+readInt16X8Array# = readInt16X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X4# #)+readInt32X4Array# = readInt32X4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X2Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X2# #)+readInt64X2Array# = readInt64X2Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X32# #)+readInt8X32Array# = readInt8X32Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X16# #)+readInt16X16Array# = readInt16X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X8# #)+readInt32X8Array# = readInt32X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X4# #)+readInt64X4Array# = readInt64X4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X64# #)+readInt8X64Array# = readInt8X64Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X32# #)+readInt16X32Array# = readInt16X32Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X16# #)+readInt32X16Array# = readInt32X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X8# #)+readInt64X8Array# = readInt64X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X16# #)+readWord8X16Array# = readWord8X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X8# #)+readWord16X8Array# = readWord16X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X4# #)+readWord32X4Array# = readWord32X4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X2Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X2# #)+readWord64X2Array# = readWord64X2Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X32# #)+readWord8X32Array# = readWord8X32Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X16# #)+readWord16X16Array# = readWord16X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X8# #)+readWord32X8Array# = readWord32X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X4# #)+readWord64X4Array# = readWord64X4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X64# #)+readWord8X64Array# = readWord8X64Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X32# #)+readWord16X32Array# = readWord16X32Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X16# #)+readWord32X16Array# = readWord32X16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X8# #)+readWord64X8Array# = readWord64X8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX4# #)+readFloatX4Array# = readFloatX4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX2Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX2# #)+readDoubleX2Array# = readDoubleX2Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX8# #)+readFloatX8Array# = readFloatX8Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX4Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX4# #)+readDoubleX4Array# = readDoubleX4Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX16# #)+readFloatX16Array# = readFloatX16Array#++{-| Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX8# #)+readDoubleX8Array# = readDoubleX8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X16Array# :: MutableByteArray# s -> Int# -> Int8X16# -> State# s -> State# s+writeInt8X16Array# = writeInt8X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X8Array# :: MutableByteArray# s -> Int# -> Int16X8# -> State# s -> State# s+writeInt16X8Array# = writeInt16X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X4Array# :: MutableByteArray# s -> Int# -> Int32X4# -> State# s -> State# s+writeInt32X4Array# = writeInt32X4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X2Array# :: MutableByteArray# s -> Int# -> Int64X2# -> State# s -> State# s+writeInt64X2Array# = writeInt64X2Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X32Array# :: MutableByteArray# s -> Int# -> Int8X32# -> State# s -> State# s+writeInt8X32Array# = writeInt8X32Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X16Array# :: MutableByteArray# s -> Int# -> Int16X16# -> State# s -> State# s+writeInt16X16Array# = writeInt16X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X8Array# :: MutableByteArray# s -> Int# -> Int32X8# -> State# s -> State# s+writeInt32X8Array# = writeInt32X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X4Array# :: MutableByteArray# s -> Int# -> Int64X4# -> State# s -> State# s+writeInt64X4Array# = writeInt64X4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X64Array# :: MutableByteArray# s -> Int# -> Int8X64# -> State# s -> State# s+writeInt8X64Array# = writeInt8X64Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X32Array# :: MutableByteArray# s -> Int# -> Int16X32# -> State# s -> State# s+writeInt16X32Array# = writeInt16X32Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X16Array# :: MutableByteArray# s -> Int# -> Int32X16# -> State# s -> State# s+writeInt32X16Array# = writeInt32X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X8Array# :: MutableByteArray# s -> Int# -> Int64X8# -> State# s -> State# s+writeInt64X8Array# = writeInt64X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X16Array# :: MutableByteArray# s -> Int# -> Word8X16# -> State# s -> State# s+writeWord8X16Array# = writeWord8X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X8Array# :: MutableByteArray# s -> Int# -> Word16X8# -> State# s -> State# s+writeWord16X8Array# = writeWord16X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X4Array# :: MutableByteArray# s -> Int# -> Word32X4# -> State# s -> State# s+writeWord32X4Array# = writeWord32X4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X2Array# :: MutableByteArray# s -> Int# -> Word64X2# -> State# s -> State# s+writeWord64X2Array# = writeWord64X2Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X32Array# :: MutableByteArray# s -> Int# -> Word8X32# -> State# s -> State# s+writeWord8X32Array# = writeWord8X32Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X16Array# :: MutableByteArray# s -> Int# -> Word16X16# -> State# s -> State# s+writeWord16X16Array# = writeWord16X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X8Array# :: MutableByteArray# s -> Int# -> Word32X8# -> State# s -> State# s+writeWord32X8Array# = writeWord32X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X4Array# :: MutableByteArray# s -> Int# -> Word64X4# -> State# s -> State# s+writeWord64X4Array# = writeWord64X4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X64Array# :: MutableByteArray# s -> Int# -> Word8X64# -> State# s -> State# s+writeWord8X64Array# = writeWord8X64Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X32Array# :: MutableByteArray# s -> Int# -> Word16X32# -> State# s -> State# s+writeWord16X32Array# = writeWord16X32Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X16Array# :: MutableByteArray# s -> Int# -> Word32X16# -> State# s -> State# s+writeWord32X16Array# = writeWord32X16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X8Array# :: MutableByteArray# s -> Int# -> Word64X8# -> State# s -> State# s+writeWord64X8Array# = writeWord64X8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX4Array# :: MutableByteArray# s -> Int# -> FloatX4# -> State# s -> State# s+writeFloatX4Array# = writeFloatX4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX2Array# :: MutableByteArray# s -> Int# -> DoubleX2# -> State# s -> State# s+writeDoubleX2Array# = writeDoubleX2Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX8Array# :: MutableByteArray# s -> Int# -> FloatX8# -> State# s -> State# s+writeFloatX8Array# = writeFloatX8Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX4Array# :: MutableByteArray# s -> Int# -> DoubleX4# -> State# s -> State# s+writeDoubleX4Array# = writeDoubleX4Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX16Array# :: MutableByteArray# s -> Int# -> FloatX16# -> State# s -> State# s+writeFloatX16Array# = writeFloatX16Array#++{-| Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX8Array# :: MutableByteArray# s -> Int# -> DoubleX8# -> State# s -> State# s+writeDoubleX8Array# = writeDoubleX8Array#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt8X16OffAddr# :: Addr# -> Int# -> Int8X16#+indexInt8X16OffAddr# = indexInt8X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt16X8OffAddr# :: Addr# -> Int# -> Int16X8#+indexInt16X8OffAddr# = indexInt16X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt32X4OffAddr# :: Addr# -> Int# -> Int32X4#+indexInt32X4OffAddr# = indexInt32X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt64X2OffAddr# :: Addr# -> Int# -> Int64X2#+indexInt64X2OffAddr# = indexInt64X2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt8X32OffAddr# :: Addr# -> Int# -> Int8X32#+indexInt8X32OffAddr# = indexInt8X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt16X16OffAddr# :: Addr# -> Int# -> Int16X16#+indexInt16X16OffAddr# = indexInt16X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt32X8OffAddr# :: Addr# -> Int# -> Int32X8#+indexInt32X8OffAddr# = indexInt32X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt64X4OffAddr# :: Addr# -> Int# -> Int64X4#+indexInt64X4OffAddr# = indexInt64X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt8X64OffAddr# :: Addr# -> Int# -> Int8X64#+indexInt8X64OffAddr# = indexInt8X64OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt16X32OffAddr# :: Addr# -> Int# -> Int16X32#+indexInt16X32OffAddr# = indexInt16X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt32X16OffAddr# :: Addr# -> Int# -> Int32X16#+indexInt32X16OffAddr# = indexInt32X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexInt64X8OffAddr# :: Addr# -> Int# -> Int64X8#+indexInt64X8OffAddr# = indexInt64X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord8X16OffAddr# :: Addr# -> Int# -> Word8X16#+indexWord8X16OffAddr# = indexWord8X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord16X8OffAddr# :: Addr# -> Int# -> Word16X8#+indexWord16X8OffAddr# = indexWord16X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord32X4OffAddr# :: Addr# -> Int# -> Word32X4#+indexWord32X4OffAddr# = indexWord32X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord64X2OffAddr# :: Addr# -> Int# -> Word64X2#+indexWord64X2OffAddr# = indexWord64X2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord8X32OffAddr# :: Addr# -> Int# -> Word8X32#+indexWord8X32OffAddr# = indexWord8X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord16X16OffAddr# :: Addr# -> Int# -> Word16X16#+indexWord16X16OffAddr# = indexWord16X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord32X8OffAddr# :: Addr# -> Int# -> Word32X8#+indexWord32X8OffAddr# = indexWord32X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord64X4OffAddr# :: Addr# -> Int# -> Word64X4#+indexWord64X4OffAddr# = indexWord64X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord8X64OffAddr# :: Addr# -> Int# -> Word8X64#+indexWord8X64OffAddr# = indexWord8X64OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord16X32OffAddr# :: Addr# -> Int# -> Word16X32#+indexWord16X32OffAddr# = indexWord16X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord32X16OffAddr# :: Addr# -> Int# -> Word32X16#+indexWord32X16OffAddr# = indexWord32X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexWord64X8OffAddr# :: Addr# -> Int# -> Word64X8#+indexWord64X8OffAddr# = indexWord64X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexFloatX4OffAddr# :: Addr# -> Int# -> FloatX4#+indexFloatX4OffAddr# = indexFloatX4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexDoubleX2OffAddr# :: Addr# -> Int# -> DoubleX2#+indexDoubleX2OffAddr# = indexDoubleX2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexFloatX8OffAddr# :: Addr# -> Int# -> FloatX8#+indexFloatX8OffAddr# = indexFloatX8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexDoubleX4OffAddr# :: Addr# -> Int# -> DoubleX4#+indexDoubleX4OffAddr# = indexDoubleX4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexFloatX16OffAddr# :: Addr# -> Int# -> FloatX16#+indexFloatX16OffAddr# = indexFloatX16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). -}+indexDoubleX8OffAddr# :: Addr# -> Int# -> DoubleX8#+indexDoubleX8OffAddr# = indexDoubleX8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8X16# #)+readInt8X16OffAddr# = readInt8X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16X8# #)+readInt16X8OffAddr# = readInt16X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32X4# #)+readInt32X4OffAddr# = readInt32X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X2OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64X2# #)+readInt64X2OffAddr# = readInt64X2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8X32# #)+readInt8X32OffAddr# = readInt8X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16X16# #)+readInt16X16OffAddr# = readInt16X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32X8# #)+readInt32X8OffAddr# = readInt32X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64X4# #)+readInt64X4OffAddr# = readInt64X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8X64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8X64# #)+readInt8X64OffAddr# = readInt8X64OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16X32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16X32# #)+readInt16X32OffAddr# = readInt16X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32X16# #)+readInt32X16OffAddr# = readInt32X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64X8# #)+readInt64X8OffAddr# = readInt64X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8X16# #)+readWord8X16OffAddr# = readWord8X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16X8# #)+readWord16X8OffAddr# = readWord16X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32X4# #)+readWord32X4OffAddr# = readWord32X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X2OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64X2# #)+readWord64X2OffAddr# = readWord64X2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8X32# #)+readWord8X32OffAddr# = readWord8X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16X16# #)+readWord16X16OffAddr# = readWord16X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32X8# #)+readWord32X8OffAddr# = readWord32X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64X4# #)+readWord64X4OffAddr# = readWord64X4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8X64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8X64# #)+readWord8X64OffAddr# = readWord8X64OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16X32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16X32# #)+readWord16X32OffAddr# = readWord16X32OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32X16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32X16# #)+readWord32X16OffAddr# = readWord32X16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64X8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64X8# #)+readWord64X8OffAddr# = readWord64X8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,FloatX4# #)+readFloatX4OffAddr# = readFloatX4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX2OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX2# #)+readDoubleX2OffAddr# = readDoubleX2OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,FloatX8# #)+readFloatX8OffAddr# = readFloatX8OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX4OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX4# #)+readDoubleX4OffAddr# = readDoubleX4OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatX16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,FloatX16# #)+readFloatX16OffAddr# = readFloatX16OffAddr#++{-| Reads vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleX8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX8# #)+readDoubleX8OffAddr# = readDoubleX8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X16OffAddr# :: Addr# -> Int# -> Int8X16# -> State# s -> State# s+writeInt8X16OffAddr# = writeInt8X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X8OffAddr# :: Addr# -> Int# -> Int16X8# -> State# s -> State# s+writeInt16X8OffAddr# = writeInt16X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X4OffAddr# :: Addr# -> Int# -> Int32X4# -> State# s -> State# s+writeInt32X4OffAddr# = writeInt32X4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X2OffAddr# :: Addr# -> Int# -> Int64X2# -> State# s -> State# s+writeInt64X2OffAddr# = writeInt64X2OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X32OffAddr# :: Addr# -> Int# -> Int8X32# -> State# s -> State# s+writeInt8X32OffAddr# = writeInt8X32OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X16OffAddr# :: Addr# -> Int# -> Int16X16# -> State# s -> State# s+writeInt16X16OffAddr# = writeInt16X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X8OffAddr# :: Addr# -> Int# -> Int32X8# -> State# s -> State# s+writeInt32X8OffAddr# = writeInt32X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X4OffAddr# :: Addr# -> Int# -> Int64X4# -> State# s -> State# s+writeInt64X4OffAddr# = writeInt64X4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8X64OffAddr# :: Addr# -> Int# -> Int8X64# -> State# s -> State# s+writeInt8X64OffAddr# = writeInt8X64OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16X32OffAddr# :: Addr# -> Int# -> Int16X32# -> State# s -> State# s+writeInt16X32OffAddr# = writeInt16X32OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32X16OffAddr# :: Addr# -> Int# -> Int32X16# -> State# s -> State# s+writeInt32X16OffAddr# = writeInt32X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64X8OffAddr# :: Addr# -> Int# -> Int64X8# -> State# s -> State# s+writeInt64X8OffAddr# = writeInt64X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X16OffAddr# :: Addr# -> Int# -> Word8X16# -> State# s -> State# s+writeWord8X16OffAddr# = writeWord8X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X8OffAddr# :: Addr# -> Int# -> Word16X8# -> State# s -> State# s+writeWord16X8OffAddr# = writeWord16X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X4OffAddr# :: Addr# -> Int# -> Word32X4# -> State# s -> State# s+writeWord32X4OffAddr# = writeWord32X4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X2OffAddr# :: Addr# -> Int# -> Word64X2# -> State# s -> State# s+writeWord64X2OffAddr# = writeWord64X2OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X32OffAddr# :: Addr# -> Int# -> Word8X32# -> State# s -> State# s+writeWord8X32OffAddr# = writeWord8X32OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X16OffAddr# :: Addr# -> Int# -> Word16X16# -> State# s -> State# s+writeWord16X16OffAddr# = writeWord16X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X8OffAddr# :: Addr# -> Int# -> Word32X8# -> State# s -> State# s+writeWord32X8OffAddr# = writeWord32X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X4OffAddr# :: Addr# -> Int# -> Word64X4# -> State# s -> State# s+writeWord64X4OffAddr# = writeWord64X4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8X64OffAddr# :: Addr# -> Int# -> Word8X64# -> State# s -> State# s+writeWord8X64OffAddr# = writeWord8X64OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16X32OffAddr# :: Addr# -> Int# -> Word16X32# -> State# s -> State# s+writeWord16X32OffAddr# = writeWord16X32OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32X16OffAddr# :: Addr# -> Int# -> Word32X16# -> State# s -> State# s+writeWord32X16OffAddr# = writeWord32X16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64X8OffAddr# :: Addr# -> Int# -> Word64X8# -> State# s -> State# s+writeWord64X8OffAddr# = writeWord64X8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX4OffAddr# :: Addr# -> Int# -> FloatX4# -> State# s -> State# s+writeFloatX4OffAddr# = writeFloatX4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX2OffAddr# :: Addr# -> Int# -> DoubleX2# -> State# s -> State# s+writeDoubleX2OffAddr# = writeDoubleX2OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX8OffAddr# :: Addr# -> Int# -> FloatX8# -> State# s -> State# s+writeFloatX8OffAddr# = writeFloatX8OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX4OffAddr# :: Addr# -> Int# -> DoubleX4# -> State# s -> State# s+writeDoubleX4OffAddr# = writeDoubleX4OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatX16OffAddr# :: Addr# -> Int# -> FloatX16# -> State# s -> State# s+writeFloatX16OffAddr# = writeFloatX16OffAddr#++{-| Write vector; offset in units of SIMD vectors (not scalar elements). ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleX8OffAddr# :: Addr# -> Int# -> DoubleX8# -> State# s -> State# s+writeDoubleX8OffAddr# = writeDoubleX8OffAddr#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt8ArrayAsInt8X16# :: ByteArray# -> Int# -> Int8X16#+indexInt8ArrayAsInt8X16# = indexInt8ArrayAsInt8X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt16ArrayAsInt16X8# :: ByteArray# -> Int# -> Int16X8#+indexInt16ArrayAsInt16X8# = indexInt16ArrayAsInt16X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt32ArrayAsInt32X4# :: ByteArray# -> Int# -> Int32X4#+indexInt32ArrayAsInt32X4# = indexInt32ArrayAsInt32X4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt64ArrayAsInt64X2# :: ByteArray# -> Int# -> Int64X2#+indexInt64ArrayAsInt64X2# = indexInt64ArrayAsInt64X2#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt8ArrayAsInt8X32# :: ByteArray# -> Int# -> Int8X32#+indexInt8ArrayAsInt8X32# = indexInt8ArrayAsInt8X32#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt16ArrayAsInt16X16# :: ByteArray# -> Int# -> Int16X16#+indexInt16ArrayAsInt16X16# = indexInt16ArrayAsInt16X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt32ArrayAsInt32X8# :: ByteArray# -> Int# -> Int32X8#+indexInt32ArrayAsInt32X8# = indexInt32ArrayAsInt32X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt64ArrayAsInt64X4# :: ByteArray# -> Int# -> Int64X4#+indexInt64ArrayAsInt64X4# = indexInt64ArrayAsInt64X4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt8ArrayAsInt8X64# :: ByteArray# -> Int# -> Int8X64#+indexInt8ArrayAsInt8X64# = indexInt8ArrayAsInt8X64#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt16ArrayAsInt16X32# :: ByteArray# -> Int# -> Int16X32#+indexInt16ArrayAsInt16X32# = indexInt16ArrayAsInt16X32#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt32ArrayAsInt32X16# :: ByteArray# -> Int# -> Int32X16#+indexInt32ArrayAsInt32X16# = indexInt32ArrayAsInt32X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexInt64ArrayAsInt64X8# :: ByteArray# -> Int# -> Int64X8#+indexInt64ArrayAsInt64X8# = indexInt64ArrayAsInt64X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord8ArrayAsWord8X16# :: ByteArray# -> Int# -> Word8X16#+indexWord8ArrayAsWord8X16# = indexWord8ArrayAsWord8X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord16ArrayAsWord16X8# :: ByteArray# -> Int# -> Word16X8#+indexWord16ArrayAsWord16X8# = indexWord16ArrayAsWord16X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord32ArrayAsWord32X4# :: ByteArray# -> Int# -> Word32X4#+indexWord32ArrayAsWord32X4# = indexWord32ArrayAsWord32X4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord64ArrayAsWord64X2# :: ByteArray# -> Int# -> Word64X2#+indexWord64ArrayAsWord64X2# = indexWord64ArrayAsWord64X2#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32#+indexWord8ArrayAsWord8X32# = indexWord8ArrayAsWord8X32#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord16ArrayAsWord16X16# :: ByteArray# -> Int# -> Word16X16#+indexWord16ArrayAsWord16X16# = indexWord16ArrayAsWord16X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord32ArrayAsWord32X8# :: ByteArray# -> Int# -> Word32X8#+indexWord32ArrayAsWord32X8# = indexWord32ArrayAsWord32X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord64ArrayAsWord64X4# :: ByteArray# -> Int# -> Word64X4#+indexWord64ArrayAsWord64X4# = indexWord64ArrayAsWord64X4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64#+indexWord8ArrayAsWord8X64# = indexWord8ArrayAsWord8X64#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord16ArrayAsWord16X32# :: ByteArray# -> Int# -> Word16X32#+indexWord16ArrayAsWord16X32# = indexWord16ArrayAsWord16X32#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord32ArrayAsWord32X16# :: ByteArray# -> Int# -> Word32X16#+indexWord32ArrayAsWord32X16# = indexWord32ArrayAsWord32X16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexWord64ArrayAsWord64X8# :: ByteArray# -> Int# -> Word64X8#+indexWord64ArrayAsWord64X8# = indexWord64ArrayAsWord64X8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexFloatArrayAsFloatX4# :: ByteArray# -> Int# -> FloatX4#+indexFloatArrayAsFloatX4# = indexFloatArrayAsFloatX4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexDoubleArrayAsDoubleX2# :: ByteArray# -> Int# -> DoubleX2#+indexDoubleArrayAsDoubleX2# = indexDoubleArrayAsDoubleX2#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexFloatArrayAsFloatX8# :: ByteArray# -> Int# -> FloatX8#+indexFloatArrayAsFloatX8# = indexFloatArrayAsFloatX8#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexDoubleArrayAsDoubleX4# :: ByteArray# -> Int# -> DoubleX4#+indexDoubleArrayAsDoubleX4# = indexDoubleArrayAsDoubleX4#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexFloatArrayAsFloatX16# :: ByteArray# -> Int# -> FloatX16#+indexFloatArrayAsFloatX16# = indexFloatArrayAsFloatX16#++{-| Read a vector from specified index of immutable array of scalars; offset is in scalar elements. -}+indexDoubleArrayAsDoubleX8# :: ByteArray# -> Int# -> DoubleX8#+indexDoubleArrayAsDoubleX8# = indexDoubleArrayAsDoubleX8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8ArrayAsInt8X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X16# #)+readInt8ArrayAsInt8X16# = readInt8ArrayAsInt8X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16ArrayAsInt16X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X8# #)+readInt16ArrayAsInt16X8# = readInt16ArrayAsInt16X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32ArrayAsInt32X4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X4# #)+readInt32ArrayAsInt32X4# = readInt32ArrayAsInt32X4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64ArrayAsInt64X2# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X2# #)+readInt64ArrayAsInt64X2# = readInt64ArrayAsInt64X2#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8ArrayAsInt8X32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X32# #)+readInt8ArrayAsInt8X32# = readInt8ArrayAsInt8X32#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16ArrayAsInt16X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X16# #)+readInt16ArrayAsInt16X16# = readInt16ArrayAsInt16X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32ArrayAsInt32X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X8# #)+readInt32ArrayAsInt32X8# = readInt32ArrayAsInt32X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64ArrayAsInt64X4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X4# #)+readInt64ArrayAsInt64X4# = readInt64ArrayAsInt64X4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8ArrayAsInt8X64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8X64# #)+readInt8ArrayAsInt8X64# = readInt8ArrayAsInt8X64#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16ArrayAsInt16X32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16X32# #)+readInt16ArrayAsInt16X32# = readInt16ArrayAsInt16X32#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32ArrayAsInt32X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32X16# #)+readInt32ArrayAsInt32X16# = readInt32ArrayAsInt32X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64ArrayAsInt64X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64X8# #)+readInt64ArrayAsInt64X8# = readInt64ArrayAsInt64X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord8X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X16# #)+readWord8ArrayAsWord8X16# = readWord8ArrayAsWord8X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16ArrayAsWord16X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X8# #)+readWord16ArrayAsWord16X8# = readWord16ArrayAsWord16X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32ArrayAsWord32X4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X4# #)+readWord32ArrayAsWord32X4# = readWord32ArrayAsWord32X4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64ArrayAsWord64X2# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X2# #)+readWord64ArrayAsWord64X2# = readWord64ArrayAsWord64X2#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord8X32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X32# #)+readWord8ArrayAsWord8X32# = readWord8ArrayAsWord8X32#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16ArrayAsWord16X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X16# #)+readWord16ArrayAsWord16X16# = readWord16ArrayAsWord16X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32ArrayAsWord32X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X8# #)+readWord32ArrayAsWord32X8# = readWord32ArrayAsWord32X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64ArrayAsWord64X4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X4# #)+readWord64ArrayAsWord64X4# = readWord64ArrayAsWord64X4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8ArrayAsWord8X64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8X64# #)+readWord8ArrayAsWord8X64# = readWord8ArrayAsWord8X64#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16ArrayAsWord16X32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16X32# #)+readWord16ArrayAsWord16X32# = readWord16ArrayAsWord16X32#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32ArrayAsWord32X16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32X16# #)+readWord32ArrayAsWord32X16# = readWord32ArrayAsWord32X16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64ArrayAsWord64X8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64X8# #)+readWord64ArrayAsWord64X8# = readWord64ArrayAsWord64X8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatArrayAsFloatX4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX4# #)+readFloatArrayAsFloatX4# = readFloatArrayAsFloatX4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleArrayAsDoubleX2# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX2# #)+readDoubleArrayAsDoubleX2# = readDoubleArrayAsDoubleX2#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatArrayAsFloatX8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX8# #)+readFloatArrayAsFloatX8# = readFloatArrayAsFloatX8#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleArrayAsDoubleX4# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX4# #)+readDoubleArrayAsDoubleX4# = readDoubleArrayAsDoubleX4#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatArrayAsFloatX16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,FloatX16# #)+readFloatArrayAsFloatX16# = readFloatArrayAsFloatX16#++{-| Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleArrayAsDoubleX8# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,DoubleX8# #)+readDoubleArrayAsDoubleX8# = readDoubleArrayAsDoubleX8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8ArrayAsInt8X16# :: MutableByteArray# s -> Int# -> Int8X16# -> State# s -> State# s+writeInt8ArrayAsInt8X16# = writeInt8ArrayAsInt8X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16ArrayAsInt16X8# :: MutableByteArray# s -> Int# -> Int16X8# -> State# s -> State# s+writeInt16ArrayAsInt16X8# = writeInt16ArrayAsInt16X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32ArrayAsInt32X4# :: MutableByteArray# s -> Int# -> Int32X4# -> State# s -> State# s+writeInt32ArrayAsInt32X4# = writeInt32ArrayAsInt32X4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64ArrayAsInt64X2# :: MutableByteArray# s -> Int# -> Int64X2# -> State# s -> State# s+writeInt64ArrayAsInt64X2# = writeInt64ArrayAsInt64X2#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8ArrayAsInt8X32# :: MutableByteArray# s -> Int# -> Int8X32# -> State# s -> State# s+writeInt8ArrayAsInt8X32# = writeInt8ArrayAsInt8X32#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16ArrayAsInt16X16# :: MutableByteArray# s -> Int# -> Int16X16# -> State# s -> State# s+writeInt16ArrayAsInt16X16# = writeInt16ArrayAsInt16X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32ArrayAsInt32X8# :: MutableByteArray# s -> Int# -> Int32X8# -> State# s -> State# s+writeInt32ArrayAsInt32X8# = writeInt32ArrayAsInt32X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64ArrayAsInt64X4# :: MutableByteArray# s -> Int# -> Int64X4# -> State# s -> State# s+writeInt64ArrayAsInt64X4# = writeInt64ArrayAsInt64X4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8ArrayAsInt8X64# :: MutableByteArray# s -> Int# -> Int8X64# -> State# s -> State# s+writeInt8ArrayAsInt8X64# = writeInt8ArrayAsInt8X64#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16ArrayAsInt16X32# :: MutableByteArray# s -> Int# -> Int16X32# -> State# s -> State# s+writeInt16ArrayAsInt16X32# = writeInt16ArrayAsInt16X32#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32ArrayAsInt32X16# :: MutableByteArray# s -> Int# -> Int32X16# -> State# s -> State# s+writeInt32ArrayAsInt32X16# = writeInt32ArrayAsInt32X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64ArrayAsInt64X8# :: MutableByteArray# s -> Int# -> Int64X8# -> State# s -> State# s+writeInt64ArrayAsInt64X8# = writeInt64ArrayAsInt64X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord8X16# :: MutableByteArray# s -> Int# -> Word8X16# -> State# s -> State# s+writeWord8ArrayAsWord8X16# = writeWord8ArrayAsWord8X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16ArrayAsWord16X8# :: MutableByteArray# s -> Int# -> Word16X8# -> State# s -> State# s+writeWord16ArrayAsWord16X8# = writeWord16ArrayAsWord16X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32ArrayAsWord32X4# :: MutableByteArray# s -> Int# -> Word32X4# -> State# s -> State# s+writeWord32ArrayAsWord32X4# = writeWord32ArrayAsWord32X4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64ArrayAsWord64X2# :: MutableByteArray# s -> Int# -> Word64X2# -> State# s -> State# s+writeWord64ArrayAsWord64X2# = writeWord64ArrayAsWord64X2#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord8X32# :: MutableByteArray# s -> Int# -> Word8X32# -> State# s -> State# s+writeWord8ArrayAsWord8X32# = writeWord8ArrayAsWord8X32#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16ArrayAsWord16X16# :: MutableByteArray# s -> Int# -> Word16X16# -> State# s -> State# s+writeWord16ArrayAsWord16X16# = writeWord16ArrayAsWord16X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32ArrayAsWord32X8# :: MutableByteArray# s -> Int# -> Word32X8# -> State# s -> State# s+writeWord32ArrayAsWord32X8# = writeWord32ArrayAsWord32X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64ArrayAsWord64X4# :: MutableByteArray# s -> Int# -> Word64X4# -> State# s -> State# s+writeWord64ArrayAsWord64X4# = writeWord64ArrayAsWord64X4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8ArrayAsWord8X64# :: MutableByteArray# s -> Int# -> Word8X64# -> State# s -> State# s+writeWord8ArrayAsWord8X64# = writeWord8ArrayAsWord8X64#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16ArrayAsWord16X32# :: MutableByteArray# s -> Int# -> Word16X32# -> State# s -> State# s+writeWord16ArrayAsWord16X32# = writeWord16ArrayAsWord16X32#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32ArrayAsWord32X16# :: MutableByteArray# s -> Int# -> Word32X16# -> State# s -> State# s+writeWord32ArrayAsWord32X16# = writeWord32ArrayAsWord32X16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64ArrayAsWord64X8# :: MutableByteArray# s -> Int# -> Word64X8# -> State# s -> State# s+writeWord64ArrayAsWord64X8# = writeWord64ArrayAsWord64X8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatArrayAsFloatX4# :: MutableByteArray# s -> Int# -> FloatX4# -> State# s -> State# s+writeFloatArrayAsFloatX4# = writeFloatArrayAsFloatX4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleArrayAsDoubleX2# :: MutableByteArray# s -> Int# -> DoubleX2# -> State# s -> State# s+writeDoubleArrayAsDoubleX2# = writeDoubleArrayAsDoubleX2#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatArrayAsFloatX8# :: MutableByteArray# s -> Int# -> FloatX8# -> State# s -> State# s+writeFloatArrayAsFloatX8# = writeFloatArrayAsFloatX8#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleArrayAsDoubleX4# :: MutableByteArray# s -> Int# -> DoubleX4# -> State# s -> State# s+writeDoubleArrayAsDoubleX4# = writeDoubleArrayAsDoubleX4#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatArrayAsFloatX16# :: MutableByteArray# s -> Int# -> FloatX16# -> State# s -> State# s+writeFloatArrayAsFloatX16# = writeFloatArrayAsFloatX16#++{-| Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleArrayAsDoubleX8# :: MutableByteArray# s -> Int# -> DoubleX8# -> State# s -> State# s+writeDoubleArrayAsDoubleX8# = writeDoubleArrayAsDoubleX8#++{-| Reads vector; offset in scalar elements. -}+indexInt8OffAddrAsInt8X16# :: Addr# -> Int# -> Int8X16#+indexInt8OffAddrAsInt8X16# = indexInt8OffAddrAsInt8X16#++{-| Reads vector; offset in scalar elements. -}+indexInt16OffAddrAsInt16X8# :: Addr# -> Int# -> Int16X8#+indexInt16OffAddrAsInt16X8# = indexInt16OffAddrAsInt16X8#++{-| Reads vector; offset in scalar elements. -}+indexInt32OffAddrAsInt32X4# :: Addr# -> Int# -> Int32X4#+indexInt32OffAddrAsInt32X4# = indexInt32OffAddrAsInt32X4#++{-| Reads vector; offset in scalar elements. -}+indexInt64OffAddrAsInt64X2# :: Addr# -> Int# -> Int64X2#+indexInt64OffAddrAsInt64X2# = indexInt64OffAddrAsInt64X2#++{-| Reads vector; offset in scalar elements. -}+indexInt8OffAddrAsInt8X32# :: Addr# -> Int# -> Int8X32#+indexInt8OffAddrAsInt8X32# = indexInt8OffAddrAsInt8X32#++{-| Reads vector; offset in scalar elements. -}+indexInt16OffAddrAsInt16X16# :: Addr# -> Int# -> Int16X16#+indexInt16OffAddrAsInt16X16# = indexInt16OffAddrAsInt16X16#++{-| Reads vector; offset in scalar elements. -}+indexInt32OffAddrAsInt32X8# :: Addr# -> Int# -> Int32X8#+indexInt32OffAddrAsInt32X8# = indexInt32OffAddrAsInt32X8#++{-| Reads vector; offset in scalar elements. -}+indexInt64OffAddrAsInt64X4# :: Addr# -> Int# -> Int64X4#+indexInt64OffAddrAsInt64X4# = indexInt64OffAddrAsInt64X4#++{-| Reads vector; offset in scalar elements. -}+indexInt8OffAddrAsInt8X64# :: Addr# -> Int# -> Int8X64#+indexInt8OffAddrAsInt8X64# = indexInt8OffAddrAsInt8X64#++{-| Reads vector; offset in scalar elements. -}+indexInt16OffAddrAsInt16X32# :: Addr# -> Int# -> Int16X32#+indexInt16OffAddrAsInt16X32# = indexInt16OffAddrAsInt16X32#++{-| Reads vector; offset in scalar elements. -}+indexInt32OffAddrAsInt32X16# :: Addr# -> Int# -> Int32X16#+indexInt32OffAddrAsInt32X16# = indexInt32OffAddrAsInt32X16#++{-| Reads vector; offset in scalar elements. -}+indexInt64OffAddrAsInt64X8# :: Addr# -> Int# -> Int64X8#+indexInt64OffAddrAsInt64X8# = indexInt64OffAddrAsInt64X8#++{-| Reads vector; offset in scalar elements. -}+indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16#+indexWord8OffAddrAsWord8X16# = indexWord8OffAddrAsWord8X16#++{-| Reads vector; offset in scalar elements. -}+indexWord16OffAddrAsWord16X8# :: Addr# -> Int# -> Word16X8#+indexWord16OffAddrAsWord16X8# = indexWord16OffAddrAsWord16X8#++{-| Reads vector; offset in scalar elements. -}+indexWord32OffAddrAsWord32X4# :: Addr# -> Int# -> Word32X4#+indexWord32OffAddrAsWord32X4# = indexWord32OffAddrAsWord32X4#++{-| Reads vector; offset in scalar elements. -}+indexWord64OffAddrAsWord64X2# :: Addr# -> Int# -> Word64X2#+indexWord64OffAddrAsWord64X2# = indexWord64OffAddrAsWord64X2#++{-| Reads vector; offset in scalar elements. -}+indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32#+indexWord8OffAddrAsWord8X32# = indexWord8OffAddrAsWord8X32#++{-| Reads vector; offset in scalar elements. -}+indexWord16OffAddrAsWord16X16# :: Addr# -> Int# -> Word16X16#+indexWord16OffAddrAsWord16X16# = indexWord16OffAddrAsWord16X16#++{-| Reads vector; offset in scalar elements. -}+indexWord32OffAddrAsWord32X8# :: Addr# -> Int# -> Word32X8#+indexWord32OffAddrAsWord32X8# = indexWord32OffAddrAsWord32X8#++{-| Reads vector; offset in scalar elements. -}+indexWord64OffAddrAsWord64X4# :: Addr# -> Int# -> Word64X4#+indexWord64OffAddrAsWord64X4# = indexWord64OffAddrAsWord64X4#++{-| Reads vector; offset in scalar elements. -}+indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64#+indexWord8OffAddrAsWord8X64# = indexWord8OffAddrAsWord8X64#++{-| Reads vector; offset in scalar elements. -}+indexWord16OffAddrAsWord16X32# :: Addr# -> Int# -> Word16X32#+indexWord16OffAddrAsWord16X32# = indexWord16OffAddrAsWord16X32#++{-| Reads vector; offset in scalar elements. -}+indexWord32OffAddrAsWord32X16# :: Addr# -> Int# -> Word32X16#+indexWord32OffAddrAsWord32X16# = indexWord32OffAddrAsWord32X16#++{-| Reads vector; offset in scalar elements. -}+indexWord64OffAddrAsWord64X8# :: Addr# -> Int# -> Word64X8#+indexWord64OffAddrAsWord64X8# = indexWord64OffAddrAsWord64X8#++{-| Reads vector; offset in scalar elements. -}+indexFloatOffAddrAsFloatX4# :: Addr# -> Int# -> FloatX4#+indexFloatOffAddrAsFloatX4# = indexFloatOffAddrAsFloatX4#++{-| Reads vector; offset in scalar elements. -}+indexDoubleOffAddrAsDoubleX2# :: Addr# -> Int# -> DoubleX2#+indexDoubleOffAddrAsDoubleX2# = indexDoubleOffAddrAsDoubleX2#++{-| Reads vector; offset in scalar elements. -}+indexFloatOffAddrAsFloatX8# :: Addr# -> Int# -> FloatX8#+indexFloatOffAddrAsFloatX8# = indexFloatOffAddrAsFloatX8#++{-| Reads vector; offset in scalar elements. -}+indexDoubleOffAddrAsDoubleX4# :: Addr# -> Int# -> DoubleX4#+indexDoubleOffAddrAsDoubleX4# = indexDoubleOffAddrAsDoubleX4#++{-| Reads vector; offset in scalar elements. -}+indexFloatOffAddrAsFloatX16# :: Addr# -> Int# -> FloatX16#+indexFloatOffAddrAsFloatX16# = indexFloatOffAddrAsFloatX16#++{-| Reads vector; offset in scalar elements. -}+indexDoubleOffAddrAsDoubleX8# :: Addr# -> Int# -> DoubleX8#+indexDoubleOffAddrAsDoubleX8# = indexDoubleOffAddrAsDoubleX8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8OffAddrAsInt8X16# :: Addr# -> Int# -> State# s -> (# State# s,Int8X16# #)+readInt8OffAddrAsInt8X16# = readInt8OffAddrAsInt8X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16OffAddrAsInt16X8# :: Addr# -> Int# -> State# s -> (# State# s,Int16X8# #)+readInt16OffAddrAsInt16X8# = readInt16OffAddrAsInt16X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32OffAddrAsInt32X4# :: Addr# -> Int# -> State# s -> (# State# s,Int32X4# #)+readInt32OffAddrAsInt32X4# = readInt32OffAddrAsInt32X4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64OffAddrAsInt64X2# :: Addr# -> Int# -> State# s -> (# State# s,Int64X2# #)+readInt64OffAddrAsInt64X2# = readInt64OffAddrAsInt64X2#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8OffAddrAsInt8X32# :: Addr# -> Int# -> State# s -> (# State# s,Int8X32# #)+readInt8OffAddrAsInt8X32# = readInt8OffAddrAsInt8X32#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16OffAddrAsInt16X16# :: Addr# -> Int# -> State# s -> (# State# s,Int16X16# #)+readInt16OffAddrAsInt16X16# = readInt16OffAddrAsInt16X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32OffAddrAsInt32X8# :: Addr# -> Int# -> State# s -> (# State# s,Int32X8# #)+readInt32OffAddrAsInt32X8# = readInt32OffAddrAsInt32X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64OffAddrAsInt64X4# :: Addr# -> Int# -> State# s -> (# State# s,Int64X4# #)+readInt64OffAddrAsInt64X4# = readInt64OffAddrAsInt64X4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt8OffAddrAsInt8X64# :: Addr# -> Int# -> State# s -> (# State# s,Int8X64# #)+readInt8OffAddrAsInt8X64# = readInt8OffAddrAsInt8X64#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt16OffAddrAsInt16X32# :: Addr# -> Int# -> State# s -> (# State# s,Int16X32# #)+readInt16OffAddrAsInt16X32# = readInt16OffAddrAsInt16X32#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt32OffAddrAsInt32X16# :: Addr# -> Int# -> State# s -> (# State# s,Int32X16# #)+readInt32OffAddrAsInt32X16# = readInt32OffAddrAsInt32X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readInt64OffAddrAsInt64X8# :: Addr# -> Int# -> State# s -> (# State# s,Int64X8# #)+readInt64OffAddrAsInt64X8# = readInt64OffAddrAsInt64X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord8X16# :: Addr# -> Int# -> State# s -> (# State# s,Word8X16# #)+readWord8OffAddrAsWord8X16# = readWord8OffAddrAsWord8X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16OffAddrAsWord16X8# :: Addr# -> Int# -> State# s -> (# State# s,Word16X8# #)+readWord16OffAddrAsWord16X8# = readWord16OffAddrAsWord16X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32OffAddrAsWord32X4# :: Addr# -> Int# -> State# s -> (# State# s,Word32X4# #)+readWord32OffAddrAsWord32X4# = readWord32OffAddrAsWord32X4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64OffAddrAsWord64X2# :: Addr# -> Int# -> State# s -> (# State# s,Word64X2# #)+readWord64OffAddrAsWord64X2# = readWord64OffAddrAsWord64X2#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord8X32# :: Addr# -> Int# -> State# s -> (# State# s,Word8X32# #)+readWord8OffAddrAsWord8X32# = readWord8OffAddrAsWord8X32#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16OffAddrAsWord16X16# :: Addr# -> Int# -> State# s -> (# State# s,Word16X16# #)+readWord16OffAddrAsWord16X16# = readWord16OffAddrAsWord16X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32OffAddrAsWord32X8# :: Addr# -> Int# -> State# s -> (# State# s,Word32X8# #)+readWord32OffAddrAsWord32X8# = readWord32OffAddrAsWord32X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64OffAddrAsWord64X4# :: Addr# -> Int# -> State# s -> (# State# s,Word64X4# #)+readWord64OffAddrAsWord64X4# = readWord64OffAddrAsWord64X4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord8OffAddrAsWord8X64# :: Addr# -> Int# -> State# s -> (# State# s,Word8X64# #)+readWord8OffAddrAsWord8X64# = readWord8OffAddrAsWord8X64#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord16OffAddrAsWord16X32# :: Addr# -> Int# -> State# s -> (# State# s,Word16X32# #)+readWord16OffAddrAsWord16X32# = readWord16OffAddrAsWord16X32#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord32OffAddrAsWord32X16# :: Addr# -> Int# -> State# s -> (# State# s,Word32X16# #)+readWord32OffAddrAsWord32X16# = readWord32OffAddrAsWord32X16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readWord64OffAddrAsWord64X8# :: Addr# -> Int# -> State# s -> (# State# s,Word64X8# #)+readWord64OffAddrAsWord64X8# = readWord64OffAddrAsWord64X8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatOffAddrAsFloatX4# :: Addr# -> Int# -> State# s -> (# State# s,FloatX4# #)+readFloatOffAddrAsFloatX4# = readFloatOffAddrAsFloatX4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleOffAddrAsDoubleX2# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX2# #)+readDoubleOffAddrAsDoubleX2# = readDoubleOffAddrAsDoubleX2#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatOffAddrAsFloatX8# :: Addr# -> Int# -> State# s -> (# State# s,FloatX8# #)+readFloatOffAddrAsFloatX8# = readFloatOffAddrAsFloatX8#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleOffAddrAsDoubleX4# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX4# #)+readDoubleOffAddrAsDoubleX4# = readDoubleOffAddrAsDoubleX4#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readFloatOffAddrAsFloatX16# :: Addr# -> Int# -> State# s -> (# State# s,FloatX16# #)+readFloatOffAddrAsFloatX16# = readFloatOffAddrAsFloatX16#++{-| Reads vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+readDoubleOffAddrAsDoubleX8# :: Addr# -> Int# -> State# s -> (# State# s,DoubleX8# #)+readDoubleOffAddrAsDoubleX8# = readDoubleOffAddrAsDoubleX8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8OffAddrAsInt8X16# :: Addr# -> Int# -> Int8X16# -> State# s -> State# s+writeInt8OffAddrAsInt8X16# = writeInt8OffAddrAsInt8X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16OffAddrAsInt16X8# :: Addr# -> Int# -> Int16X8# -> State# s -> State# s+writeInt16OffAddrAsInt16X8# = writeInt16OffAddrAsInt16X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32OffAddrAsInt32X4# :: Addr# -> Int# -> Int32X4# -> State# s -> State# s+writeInt32OffAddrAsInt32X4# = writeInt32OffAddrAsInt32X4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64OffAddrAsInt64X2# :: Addr# -> Int# -> Int64X2# -> State# s -> State# s+writeInt64OffAddrAsInt64X2# = writeInt64OffAddrAsInt64X2#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8OffAddrAsInt8X32# :: Addr# -> Int# -> Int8X32# -> State# s -> State# s+writeInt8OffAddrAsInt8X32# = writeInt8OffAddrAsInt8X32#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16OffAddrAsInt16X16# :: Addr# -> Int# -> Int16X16# -> State# s -> State# s+writeInt16OffAddrAsInt16X16# = writeInt16OffAddrAsInt16X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32OffAddrAsInt32X8# :: Addr# -> Int# -> Int32X8# -> State# s -> State# s+writeInt32OffAddrAsInt32X8# = writeInt32OffAddrAsInt32X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64OffAddrAsInt64X4# :: Addr# -> Int# -> Int64X4# -> State# s -> State# s+writeInt64OffAddrAsInt64X4# = writeInt64OffAddrAsInt64X4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt8OffAddrAsInt8X64# :: Addr# -> Int# -> Int8X64# -> State# s -> State# s+writeInt8OffAddrAsInt8X64# = writeInt8OffAddrAsInt8X64#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt16OffAddrAsInt16X32# :: Addr# -> Int# -> Int16X32# -> State# s -> State# s+writeInt16OffAddrAsInt16X32# = writeInt16OffAddrAsInt16X32#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt32OffAddrAsInt32X16# :: Addr# -> Int# -> Int32X16# -> State# s -> State# s+writeInt32OffAddrAsInt32X16# = writeInt32OffAddrAsInt32X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeInt64OffAddrAsInt64X8# :: Addr# -> Int# -> Int64X8# -> State# s -> State# s+writeInt64OffAddrAsInt64X8# = writeInt64OffAddrAsInt64X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# -> State# s -> State# s+writeWord8OffAddrAsWord8X16# = writeWord8OffAddrAsWord8X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16OffAddrAsWord16X8# :: Addr# -> Int# -> Word16X8# -> State# s -> State# s+writeWord16OffAddrAsWord16X8# = writeWord16OffAddrAsWord16X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32OffAddrAsWord32X4# :: Addr# -> Int# -> Word32X4# -> State# s -> State# s+writeWord32OffAddrAsWord32X4# = writeWord32OffAddrAsWord32X4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64OffAddrAsWord64X2# :: Addr# -> Int# -> Word64X2# -> State# s -> State# s+writeWord64OffAddrAsWord64X2# = writeWord64OffAddrAsWord64X2#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# -> State# s -> State# s+writeWord8OffAddrAsWord8X32# = writeWord8OffAddrAsWord8X32#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16OffAddrAsWord16X16# :: Addr# -> Int# -> Word16X16# -> State# s -> State# s+writeWord16OffAddrAsWord16X16# = writeWord16OffAddrAsWord16X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32OffAddrAsWord32X8# :: Addr# -> Int# -> Word32X8# -> State# s -> State# s+writeWord32OffAddrAsWord32X8# = writeWord32OffAddrAsWord32X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64OffAddrAsWord64X4# :: Addr# -> Int# -> Word64X4# -> State# s -> State# s+writeWord64OffAddrAsWord64X4# = writeWord64OffAddrAsWord64X4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# -> State# s -> State# s+writeWord8OffAddrAsWord8X64# = writeWord8OffAddrAsWord8X64#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord16OffAddrAsWord16X32# :: Addr# -> Int# -> Word16X32# -> State# s -> State# s+writeWord16OffAddrAsWord16X32# = writeWord16OffAddrAsWord16X32#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord32OffAddrAsWord32X16# :: Addr# -> Int# -> Word32X16# -> State# s -> State# s+writeWord32OffAddrAsWord32X16# = writeWord32OffAddrAsWord32X16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeWord64OffAddrAsWord64X8# :: Addr# -> Int# -> Word64X8# -> State# s -> State# s+writeWord64OffAddrAsWord64X8# = writeWord64OffAddrAsWord64X8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatOffAddrAsFloatX4# :: Addr# -> Int# -> FloatX4# -> State# s -> State# s+writeFloatOffAddrAsFloatX4# = writeFloatOffAddrAsFloatX4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleOffAddrAsDoubleX2# :: Addr# -> Int# -> DoubleX2# -> State# s -> State# s+writeDoubleOffAddrAsDoubleX2# = writeDoubleOffAddrAsDoubleX2#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatOffAddrAsFloatX8# :: Addr# -> Int# -> FloatX8# -> State# s -> State# s+writeFloatOffAddrAsFloatX8# = writeFloatOffAddrAsFloatX8#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleOffAddrAsDoubleX4# :: Addr# -> Int# -> DoubleX4# -> State# s -> State# s+writeDoubleOffAddrAsDoubleX4# = writeDoubleOffAddrAsDoubleX4#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeFloatOffAddrAsFloatX16# :: Addr# -> Int# -> FloatX16# -> State# s -> State# s+writeFloatOffAddrAsFloatX16# = writeFloatOffAddrAsFloatX16#++{-| Write vector; offset in scalar elements. ++__/Warning:/__ this can fail with an unchecked exception.-}+writeDoubleOffAddrAsDoubleX8# :: Addr# -> Int# -> DoubleX8# -> State# s -> State# s+writeDoubleOffAddrAsDoubleX8# = writeDoubleOffAddrAsDoubleX8#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -> FloatX4#+fmaddFloatX4# = fmaddFloatX4#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -> DoubleX2#+fmaddDoubleX2# = fmaddDoubleX2#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddFloatX8# :: FloatX8# -> FloatX8# -> FloatX8# -> FloatX8#+fmaddFloatX8# = fmaddFloatX8#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4#+fmaddDoubleX4# = fmaddDoubleX4#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddFloatX16# :: FloatX16# -> FloatX16# -> FloatX16# -> FloatX16#+fmaddFloatX16# = fmaddFloatX16#++{-|Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".-}+fmaddDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8#+fmaddDoubleX8# = fmaddDoubleX8#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -> FloatX4#+fmsubFloatX4# = fmsubFloatX4#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -> DoubleX2#+fmsubDoubleX2# = fmsubDoubleX2#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubFloatX8# :: FloatX8# -> FloatX8# -> FloatX8# -> FloatX8#+fmsubFloatX8# = fmsubFloatX8#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4#+fmsubDoubleX4# = fmsubDoubleX4#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubFloatX16# :: FloatX16# -> FloatX16# -> FloatX16# -> FloatX16#+fmsubFloatX16# = fmsubFloatX16#++{-|Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".-}+fmsubDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8#+fmsubDoubleX8# = fmsubDoubleX8#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -> FloatX4#+fnmaddFloatX4# = fnmaddFloatX4#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -> DoubleX2#+fnmaddDoubleX2# = fnmaddDoubleX2#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddFloatX8# :: FloatX8# -> FloatX8# -> FloatX8# -> FloatX8#+fnmaddFloatX8# = fnmaddFloatX8#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4#+fnmaddDoubleX4# = fnmaddDoubleX4#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddFloatX16# :: FloatX16# -> FloatX16# -> FloatX16# -> FloatX16#+fnmaddFloatX16# = fnmaddFloatX16#++{-|Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".-}+fnmaddDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8#+fnmaddDoubleX8# = fnmaddDoubleX8#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -> FloatX4#+fnmsubFloatX4# = fnmsubFloatX4#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -> DoubleX2#+fnmsubDoubleX2# = fnmsubDoubleX2#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubFloatX8# :: FloatX8# -> FloatX8# -> FloatX8# -> FloatX8#+fnmsubFloatX8# = fnmsubFloatX8#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4#+fnmsubDoubleX4# = fnmsubDoubleX4#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubFloatX16# :: FloatX16# -> FloatX16# -> FloatX16# -> FloatX16#+fnmsubFloatX16# = fnmsubFloatX16#++{-|Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".-}+fnmsubDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8#+fnmsubDoubleX8# = fnmsubDoubleX8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt8X16# :: Int8X16# -> Int8X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int8X16#+shuffleInt8X16# = shuffleInt8X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt16X8# :: Int16X8# -> Int16X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int16X8#+shuffleInt16X8# = shuffleInt16X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt32X4# :: Int32X4# -> Int32X4# -> (# Int#,Int#,Int#,Int# #) -> Int32X4#+shuffleInt32X4# = shuffleInt32X4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt64X2# :: Int64X2# -> Int64X2# -> (# Int#,Int# #) -> Int64X2#+shuffleInt64X2# = shuffleInt64X2#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt8X32# :: Int8X32# -> Int8X32# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int8X32#+shuffleInt8X32# = shuffleInt8X32#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt16X16# :: Int16X16# -> Int16X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int16X16#+shuffleInt16X16# = shuffleInt16X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt32X8# :: Int32X8# -> Int32X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int32X8#+shuffleInt32X8# = shuffleInt32X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt64X4# :: Int64X4# -> Int64X4# -> (# Int#,Int#,Int#,Int# #) -> Int64X4#+shuffleInt64X4# = shuffleInt64X4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt8X64# :: Int8X64# -> Int8X64# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int8X64#+shuffleInt8X64# = shuffleInt8X64#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt16X32# :: Int16X32# -> Int16X32# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int16X32#+shuffleInt16X32# = shuffleInt16X32#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt32X16# :: Int32X16# -> Int32X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int32X16#+shuffleInt32X16# = shuffleInt32X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleInt64X8# :: Int64X8# -> Int64X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Int64X8#+shuffleInt64X8# = shuffleInt64X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord8X16# :: Word8X16# -> Word8X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word8X16#+shuffleWord8X16# = shuffleWord8X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord16X8# :: Word16X8# -> Word16X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word16X8#+shuffleWord16X8# = shuffleWord16X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord32X4# :: Word32X4# -> Word32X4# -> (# Int#,Int#,Int#,Int# #) -> Word32X4#+shuffleWord32X4# = shuffleWord32X4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord64X2# :: Word64X2# -> Word64X2# -> (# Int#,Int# #) -> Word64X2#+shuffleWord64X2# = shuffleWord64X2#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord8X32# :: Word8X32# -> Word8X32# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word8X32#+shuffleWord8X32# = shuffleWord8X32#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord16X16# :: Word16X16# -> Word16X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word16X16#+shuffleWord16X16# = shuffleWord16X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord32X8# :: Word32X8# -> Word32X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word32X8#+shuffleWord32X8# = shuffleWord32X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord64X4# :: Word64X4# -> Word64X4# -> (# Int#,Int#,Int#,Int# #) -> Word64X4#+shuffleWord64X4# = shuffleWord64X4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord8X64# :: Word8X64# -> Word8X64# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word8X64#+shuffleWord8X64# = shuffleWord8X64#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord16X32# :: Word16X32# -> Word16X32# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word16X32#+shuffleWord16X32# = shuffleWord16X32#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord32X16# :: Word32X16# -> Word32X16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word32X16#+shuffleWord32X16# = shuffleWord32X16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleWord64X8# :: Word64X8# -> Word64X8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> Word64X8#+shuffleWord64X8# = shuffleWord64X8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleFloatX4# :: FloatX4# -> FloatX4# -> (# Int#,Int#,Int#,Int# #) -> FloatX4#+shuffleFloatX4# = shuffleFloatX4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleDoubleX2# :: DoubleX2# -> DoubleX2# -> (# Int#,Int# #) -> DoubleX2#+shuffleDoubleX2# = shuffleDoubleX2#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleFloatX8# :: FloatX8# -> FloatX8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> FloatX8#+shuffleFloatX8# = shuffleFloatX8#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleDoubleX4# :: DoubleX4# -> DoubleX4# -> (# Int#,Int#,Int#,Int# #) -> DoubleX4#+shuffleDoubleX4# = shuffleDoubleX4#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleFloatX16# :: FloatX16# -> FloatX16# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> FloatX16#+shuffleFloatX16# = shuffleFloatX16#++{-|Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.-}+shuffleDoubleX8# :: DoubleX8# -> DoubleX8# -> (# Int#,Int#,Int#,Int#,Int#,Int#,Int#,Int# #) -> DoubleX8#+shuffleDoubleX8# = shuffleDoubleX8#++{-|Component-wise minimum of two vectors.-}+minInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+minInt8X16# = minInt8X16#++{-|Component-wise minimum of two vectors.-}+minInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+minInt16X8# = minInt16X8#++{-|Component-wise minimum of two vectors.-}+minInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+minInt32X4# = minInt32X4#++{-|Component-wise minimum of two vectors.-}+minInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+minInt64X2# = minInt64X2#++{-|Component-wise minimum of two vectors.-}+minInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+minInt8X32# = minInt8X32#++{-|Component-wise minimum of two vectors.-}+minInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+minInt16X16# = minInt16X16#++{-|Component-wise minimum of two vectors.-}+minInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+minInt32X8# = minInt32X8#++{-|Component-wise minimum of two vectors.-}+minInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+minInt64X4# = minInt64X4#++{-|Component-wise minimum of two vectors.-}+minInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+minInt8X64# = minInt8X64#++{-|Component-wise minimum of two vectors.-}+minInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+minInt16X32# = minInt16X32#++{-|Component-wise minimum of two vectors.-}+minInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+minInt32X16# = minInt32X16#++{-|Component-wise minimum of two vectors.-}+minInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+minInt64X8# = minInt64X8#++{-|Component-wise minimum of two vectors.-}+minWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+minWord8X16# = minWord8X16#++{-|Component-wise minimum of two vectors.-}+minWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+minWord16X8# = minWord16X8#++{-|Component-wise minimum of two vectors.-}+minWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+minWord32X4# = minWord32X4#++{-|Component-wise minimum of two vectors.-}+minWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+minWord64X2# = minWord64X2#++{-|Component-wise minimum of two vectors.-}+minWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+minWord8X32# = minWord8X32#++{-|Component-wise minimum of two vectors.-}+minWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+minWord16X16# = minWord16X16#++{-|Component-wise minimum of two vectors.-}+minWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+minWord32X8# = minWord32X8#++{-|Component-wise minimum of two vectors.-}+minWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+minWord64X4# = minWord64X4#++{-|Component-wise minimum of two vectors.-}+minWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+minWord8X64# = minWord8X64#++{-|Component-wise minimum of two vectors.-}+minWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+minWord16X32# = minWord16X32#++{-|Component-wise minimum of two vectors.-}+minWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+minWord32X16# = minWord32X16#++{-|Component-wise minimum of two vectors.-}+minWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+minWord64X8# = minWord64X8#++{-|Component-wise minimum of two vectors.-}+minFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+minFloatX4# = minFloatX4#++{-|Component-wise minimum of two vectors.-}+minDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+minDoubleX2# = minDoubleX2#++{-|Component-wise minimum of two vectors.-}+minFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+minFloatX8# = minFloatX8#++{-|Component-wise minimum of two vectors.-}+minDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+minDoubleX4# = minDoubleX4#++{-|Component-wise minimum of two vectors.-}+minFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+minFloatX16# = minFloatX16#++{-|Component-wise minimum of two vectors.-}+minDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+minDoubleX8# = minDoubleX8#++{-|Component-wise maximum of two vectors.-}+maxInt8X16# :: Int8X16# -> Int8X16# -> Int8X16#+maxInt8X16# = maxInt8X16#++{-|Component-wise maximum of two vectors.-}+maxInt16X8# :: Int16X8# -> Int16X8# -> Int16X8#+maxInt16X8# = maxInt16X8#++{-|Component-wise maximum of two vectors.-}+maxInt32X4# :: Int32X4# -> Int32X4# -> Int32X4#+maxInt32X4# = maxInt32X4#++{-|Component-wise maximum of two vectors.-}+maxInt64X2# :: Int64X2# -> Int64X2# -> Int64X2#+maxInt64X2# = maxInt64X2#++{-|Component-wise maximum of two vectors.-}+maxInt8X32# :: Int8X32# -> Int8X32# -> Int8X32#+maxInt8X32# = maxInt8X32#++{-|Component-wise maximum of two vectors.-}+maxInt16X16# :: Int16X16# -> Int16X16# -> Int16X16#+maxInt16X16# = maxInt16X16#++{-|Component-wise maximum of two vectors.-}+maxInt32X8# :: Int32X8# -> Int32X8# -> Int32X8#+maxInt32X8# = maxInt32X8#++{-|Component-wise maximum of two vectors.-}+maxInt64X4# :: Int64X4# -> Int64X4# -> Int64X4#+maxInt64X4# = maxInt64X4#++{-|Component-wise maximum of two vectors.-}+maxInt8X64# :: Int8X64# -> Int8X64# -> Int8X64#+maxInt8X64# = maxInt8X64#++{-|Component-wise maximum of two vectors.-}+maxInt16X32# :: Int16X32# -> Int16X32# -> Int16X32#+maxInt16X32# = maxInt16X32#++{-|Component-wise maximum of two vectors.-}+maxInt32X16# :: Int32X16# -> Int32X16# -> Int32X16#+maxInt32X16# = maxInt32X16#++{-|Component-wise maximum of two vectors.-}+maxInt64X8# :: Int64X8# -> Int64X8# -> Int64X8#+maxInt64X8# = maxInt64X8#++{-|Component-wise maximum of two vectors.-}+maxWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#+maxWord8X16# = maxWord8X16#++{-|Component-wise maximum of two vectors.-}+maxWord16X8# :: Word16X8# -> Word16X8# -> Word16X8#+maxWord16X8# = maxWord16X8#++{-|Component-wise maximum of two vectors.-}+maxWord32X4# :: Word32X4# -> Word32X4# -> Word32X4#+maxWord32X4# = maxWord32X4#++{-|Component-wise maximum of two vectors.-}+maxWord64X2# :: Word64X2# -> Word64X2# -> Word64X2#+maxWord64X2# = maxWord64X2#++{-|Component-wise maximum of two vectors.-}+maxWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#+maxWord8X32# = maxWord8X32#++{-|Component-wise maximum of two vectors.-}+maxWord16X16# :: Word16X16# -> Word16X16# -> Word16X16#+maxWord16X16# = maxWord16X16#++{-|Component-wise maximum of two vectors.-}+maxWord32X8# :: Word32X8# -> Word32X8# -> Word32X8#+maxWord32X8# = maxWord32X8#++{-|Component-wise maximum of two vectors.-}+maxWord64X4# :: Word64X4# -> Word64X4# -> Word64X4#+maxWord64X4# = maxWord64X4#++{-|Component-wise maximum of two vectors.-}+maxWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#+maxWord8X64# = maxWord8X64#++{-|Component-wise maximum of two vectors.-}+maxWord16X32# :: Word16X32# -> Word16X32# -> Word16X32#+maxWord16X32# = maxWord16X32#++{-|Component-wise maximum of two vectors.-}+maxWord32X16# :: Word32X16# -> Word32X16# -> Word32X16#+maxWord32X16# = maxWord32X16#++{-|Component-wise maximum of two vectors.-}+maxWord64X8# :: Word64X8# -> Word64X8# -> Word64X8#+maxWord64X8# = maxWord64X8#++{-|Component-wise maximum of two vectors.-}+maxFloatX4# :: FloatX4# -> FloatX4# -> FloatX4#+maxFloatX4# = maxFloatX4#++{-|Component-wise maximum of two vectors.-}+maxDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#+maxDoubleX2# = maxDoubleX2#++{-|Component-wise maximum of two vectors.-}+maxFloatX8# :: FloatX8# -> FloatX8# -> FloatX8#+maxFloatX8# = maxFloatX8#++{-|Component-wise maximum of two vectors.-}+maxDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#+maxDoubleX4# = maxDoubleX4#++{-|Component-wise maximum of two vectors.-}+maxFloatX16# :: FloatX16# -> FloatX16# -> FloatX16#+maxFloatX16# = maxFloatX16#++{-|Component-wise maximum of two vectors.-}+maxDoubleX8# :: DoubleX8# -> DoubleX8# -> DoubleX8#+maxDoubleX8# = maxDoubleX8#++prefetchByteArray3# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray3# = prefetchByteArray3#++prefetchMutableByteArray3# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray3# = prefetchMutableByteArray3#++prefetchAddr3# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr3# = prefetchAddr3#++prefetchValue3# :: a -> State# s -> State# s+prefetchValue3# = prefetchValue3#++prefetchByteArray2# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray2# = prefetchByteArray2#++prefetchMutableByteArray2# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray2# = prefetchMutableByteArray2#++prefetchAddr2# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr2# = prefetchAddr2#++prefetchValue2# :: a -> State# s -> State# s+prefetchValue2# = prefetchValue2#++prefetchByteArray1# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray1# = prefetchByteArray1#++prefetchMutableByteArray1# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray1# = prefetchMutableByteArray1#++prefetchAddr1# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr1# = prefetchAddr1#++prefetchValue1# :: a -> State# s -> State# s+prefetchValue1# = prefetchValue1#++prefetchByteArray0# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray0# = prefetchByteArray0#++prefetchMutableByteArray0# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray0# = prefetchMutableByteArray0#++prefetchAddr0# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr0# = prefetchAddr0#++prefetchValue0# :: a -> State# s -> State# s+prefetchValue0# = prefetchValue0#+++
+ ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/PrimopWrappers.hs view
@@ -0,0 +1,2210 @@+-- | Users should not import this module.  It is GHC internal only.+-- Use "GHC.Exts" instead.+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-deprecations -O0 -fno-do-eta-reduction #-}+module GHC.Internal.PrimopWrappers where+import qualified GHC.Internal.Prim+import GHC.Internal.Tuple ()+import GHC.Internal.Prim (Char#, Int#, Int8#, Word8#, Word#, Int16#, Word16#, Int32#, Word32#, Int64#, Word64#, Float#, Double#, State#, MutableArray#, Array#, SmallMutableArray#, SmallArray#, MutableByteArray#, ByteArray#, Addr#, StablePtr#, RealWorld, MutVar#, PromptTag#, TVar#, MVar#, ThreadId#, Weak#, StableName#, Compact#, BCO)+{-# NOINLINE gtChar# #-}+gtChar# :: Char# -> Char# -> Int#+gtChar# a1 a2 = GHC.Internal.Prim.gtChar# a1 a2+{-# NOINLINE geChar# #-}+geChar# :: Char# -> Char# -> Int#+geChar# a1 a2 = GHC.Internal.Prim.geChar# a1 a2+{-# NOINLINE eqChar# #-}+eqChar# :: Char# -> Char# -> Int#+eqChar# a1 a2 = GHC.Internal.Prim.eqChar# a1 a2+{-# NOINLINE neChar# #-}+neChar# :: Char# -> Char# -> Int#+neChar# a1 a2 = GHC.Internal.Prim.neChar# a1 a2+{-# NOINLINE ltChar# #-}+ltChar# :: Char# -> Char# -> Int#+ltChar# a1 a2 = GHC.Internal.Prim.ltChar# a1 a2+{-# NOINLINE leChar# #-}+leChar# :: Char# -> Char# -> Int#+leChar# a1 a2 = GHC.Internal.Prim.leChar# a1 a2+{-# NOINLINE ord# #-}+ord# :: Char# -> Int#+ord# a1 = GHC.Internal.Prim.ord# a1+{-# NOINLINE int8ToInt# #-}+int8ToInt# :: Int8# -> Int#+int8ToInt# a1 = GHC.Internal.Prim.int8ToInt# a1+{-# NOINLINE intToInt8# #-}+intToInt8# :: Int# -> Int8#+intToInt8# a1 = GHC.Internal.Prim.intToInt8# a1+{-# NOINLINE negateInt8# #-}+negateInt8# :: Int8# -> Int8#+negateInt8# a1 = GHC.Internal.Prim.negateInt8# a1+{-# NOINLINE plusInt8# #-}+plusInt8# :: Int8# -> Int8# -> Int8#+plusInt8# a1 a2 = GHC.Internal.Prim.plusInt8# a1 a2+{-# NOINLINE subInt8# #-}+subInt8# :: Int8# -> Int8# -> Int8#+subInt8# a1 a2 = GHC.Internal.Prim.subInt8# a1 a2+{-# NOINLINE timesInt8# #-}+timesInt8# :: Int8# -> Int8# -> Int8#+timesInt8# a1 a2 = GHC.Internal.Prim.timesInt8# a1 a2+{-# NOINLINE quotInt8# #-}+quotInt8# :: Int8# -> Int8# -> Int8#+quotInt8# a1 a2 = GHC.Internal.Prim.quotInt8# a1 a2+{-# NOINLINE remInt8# #-}+remInt8# :: Int8# -> Int8# -> Int8#+remInt8# a1 a2 = GHC.Internal.Prim.remInt8# a1 a2+{-# NOINLINE quotRemInt8# #-}+quotRemInt8# :: Int8# -> Int8# -> (# Int8#,Int8# #)+quotRemInt8# a1 a2 = GHC.Internal.Prim.quotRemInt8# a1 a2+{-# NOINLINE uncheckedShiftLInt8# #-}+uncheckedShiftLInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftLInt8# a1 a2 = GHC.Internal.Prim.uncheckedShiftLInt8# a1 a2+{-# NOINLINE uncheckedShiftRAInt8# #-}+uncheckedShiftRAInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftRAInt8# a1 a2 = GHC.Internal.Prim.uncheckedShiftRAInt8# a1 a2+{-# NOINLINE uncheckedShiftRLInt8# #-}+uncheckedShiftRLInt8# :: Int8# -> Int# -> Int8#+uncheckedShiftRLInt8# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLInt8# a1 a2+{-# NOINLINE int8ToWord8# #-}+int8ToWord8# :: Int8# -> Word8#+int8ToWord8# a1 = GHC.Internal.Prim.int8ToWord8# a1+{-# NOINLINE eqInt8# #-}+eqInt8# :: Int8# -> Int8# -> Int#+eqInt8# a1 a2 = GHC.Internal.Prim.eqInt8# a1 a2+{-# NOINLINE geInt8# #-}+geInt8# :: Int8# -> Int8# -> Int#+geInt8# a1 a2 = GHC.Internal.Prim.geInt8# a1 a2+{-# NOINLINE gtInt8# #-}+gtInt8# :: Int8# -> Int8# -> Int#+gtInt8# a1 a2 = GHC.Internal.Prim.gtInt8# a1 a2+{-# NOINLINE leInt8# #-}+leInt8# :: Int8# -> Int8# -> Int#+leInt8# a1 a2 = GHC.Internal.Prim.leInt8# a1 a2+{-# NOINLINE ltInt8# #-}+ltInt8# :: Int8# -> Int8# -> Int#+ltInt8# a1 a2 = GHC.Internal.Prim.ltInt8# a1 a2+{-# NOINLINE neInt8# #-}+neInt8# :: Int8# -> Int8# -> Int#+neInt8# a1 a2 = GHC.Internal.Prim.neInt8# a1 a2+{-# NOINLINE word8ToWord# #-}+word8ToWord# :: Word8# -> Word#+word8ToWord# a1 = GHC.Internal.Prim.word8ToWord# a1+{-# NOINLINE wordToWord8# #-}+wordToWord8# :: Word# -> Word8#+wordToWord8# a1 = GHC.Internal.Prim.wordToWord8# a1+{-# NOINLINE plusWord8# #-}+plusWord8# :: Word8# -> Word8# -> Word8#+plusWord8# a1 a2 = GHC.Internal.Prim.plusWord8# a1 a2+{-# NOINLINE subWord8# #-}+subWord8# :: Word8# -> Word8# -> Word8#+subWord8# a1 a2 = GHC.Internal.Prim.subWord8# a1 a2+{-# NOINLINE timesWord8# #-}+timesWord8# :: Word8# -> Word8# -> Word8#+timesWord8# a1 a2 = GHC.Internal.Prim.timesWord8# a1 a2+{-# NOINLINE quotWord8# #-}+quotWord8# :: Word8# -> Word8# -> Word8#+quotWord8# a1 a2 = GHC.Internal.Prim.quotWord8# a1 a2+{-# NOINLINE remWord8# #-}+remWord8# :: Word8# -> Word8# -> Word8#+remWord8# a1 a2 = GHC.Internal.Prim.remWord8# a1 a2+{-# NOINLINE quotRemWord8# #-}+quotRemWord8# :: Word8# -> Word8# -> (# Word8#,Word8# #)+quotRemWord8# a1 a2 = GHC.Internal.Prim.quotRemWord8# a1 a2+{-# NOINLINE andWord8# #-}+andWord8# :: Word8# -> Word8# -> Word8#+andWord8# a1 a2 = GHC.Internal.Prim.andWord8# a1 a2+{-# NOINLINE orWord8# #-}+orWord8# :: Word8# -> Word8# -> Word8#+orWord8# a1 a2 = GHC.Internal.Prim.orWord8# a1 a2+{-# NOINLINE xorWord8# #-}+xorWord8# :: Word8# -> Word8# -> Word8#+xorWord8# a1 a2 = GHC.Internal.Prim.xorWord8# a1 a2+{-# NOINLINE notWord8# #-}+notWord8# :: Word8# -> Word8#+notWord8# a1 = GHC.Internal.Prim.notWord8# a1+{-# NOINLINE uncheckedShiftLWord8# #-}+uncheckedShiftLWord8# :: Word8# -> Int# -> Word8#+uncheckedShiftLWord8# a1 a2 = GHC.Internal.Prim.uncheckedShiftLWord8# a1 a2+{-# NOINLINE uncheckedShiftRLWord8# #-}+uncheckedShiftRLWord8# :: Word8# -> Int# -> Word8#+uncheckedShiftRLWord8# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLWord8# a1 a2+{-# NOINLINE word8ToInt8# #-}+word8ToInt8# :: Word8# -> Int8#+word8ToInt8# a1 = GHC.Internal.Prim.word8ToInt8# a1+{-# NOINLINE eqWord8# #-}+eqWord8# :: Word8# -> Word8# -> Int#+eqWord8# a1 a2 = GHC.Internal.Prim.eqWord8# a1 a2+{-# NOINLINE geWord8# #-}+geWord8# :: Word8# -> Word8# -> Int#+geWord8# a1 a2 = GHC.Internal.Prim.geWord8# a1 a2+{-# NOINLINE gtWord8# #-}+gtWord8# :: Word8# -> Word8# -> Int#+gtWord8# a1 a2 = GHC.Internal.Prim.gtWord8# a1 a2+{-# NOINLINE leWord8# #-}+leWord8# :: Word8# -> Word8# -> Int#+leWord8# a1 a2 = GHC.Internal.Prim.leWord8# a1 a2+{-# NOINLINE ltWord8# #-}+ltWord8# :: Word8# -> Word8# -> Int#+ltWord8# a1 a2 = GHC.Internal.Prim.ltWord8# a1 a2+{-# NOINLINE neWord8# #-}+neWord8# :: Word8# -> Word8# -> Int#+neWord8# a1 a2 = GHC.Internal.Prim.neWord8# a1 a2+{-# NOINLINE int16ToInt# #-}+int16ToInt# :: Int16# -> Int#+int16ToInt# a1 = GHC.Internal.Prim.int16ToInt# a1+{-# NOINLINE intToInt16# #-}+intToInt16# :: Int# -> Int16#+intToInt16# a1 = GHC.Internal.Prim.intToInt16# a1+{-# NOINLINE negateInt16# #-}+negateInt16# :: Int16# -> Int16#+negateInt16# a1 = GHC.Internal.Prim.negateInt16# a1+{-# NOINLINE plusInt16# #-}+plusInt16# :: Int16# -> Int16# -> Int16#+plusInt16# a1 a2 = GHC.Internal.Prim.plusInt16# a1 a2+{-# NOINLINE subInt16# #-}+subInt16# :: Int16# -> Int16# -> Int16#+subInt16# a1 a2 = GHC.Internal.Prim.subInt16# a1 a2+{-# NOINLINE timesInt16# #-}+timesInt16# :: Int16# -> Int16# -> Int16#+timesInt16# a1 a2 = GHC.Internal.Prim.timesInt16# a1 a2+{-# NOINLINE quotInt16# #-}+quotInt16# :: Int16# -> Int16# -> Int16#+quotInt16# a1 a2 = GHC.Internal.Prim.quotInt16# a1 a2+{-# NOINLINE remInt16# #-}+remInt16# :: Int16# -> Int16# -> Int16#+remInt16# a1 a2 = GHC.Internal.Prim.remInt16# a1 a2+{-# NOINLINE quotRemInt16# #-}+quotRemInt16# :: Int16# -> Int16# -> (# Int16#,Int16# #)+quotRemInt16# a1 a2 = GHC.Internal.Prim.quotRemInt16# a1 a2+{-# NOINLINE uncheckedShiftLInt16# #-}+uncheckedShiftLInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftLInt16# a1 a2 = GHC.Internal.Prim.uncheckedShiftLInt16# a1 a2+{-# NOINLINE uncheckedShiftRAInt16# #-}+uncheckedShiftRAInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftRAInt16# a1 a2 = GHC.Internal.Prim.uncheckedShiftRAInt16# a1 a2+{-# NOINLINE uncheckedShiftRLInt16# #-}+uncheckedShiftRLInt16# :: Int16# -> Int# -> Int16#+uncheckedShiftRLInt16# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLInt16# a1 a2+{-# NOINLINE int16ToWord16# #-}+int16ToWord16# :: Int16# -> Word16#+int16ToWord16# a1 = GHC.Internal.Prim.int16ToWord16# a1+{-# NOINLINE eqInt16# #-}+eqInt16# :: Int16# -> Int16# -> Int#+eqInt16# a1 a2 = GHC.Internal.Prim.eqInt16# a1 a2+{-# NOINLINE geInt16# #-}+geInt16# :: Int16# -> Int16# -> Int#+geInt16# a1 a2 = GHC.Internal.Prim.geInt16# a1 a2+{-# NOINLINE gtInt16# #-}+gtInt16# :: Int16# -> Int16# -> Int#+gtInt16# a1 a2 = GHC.Internal.Prim.gtInt16# a1 a2+{-# NOINLINE leInt16# #-}+leInt16# :: Int16# -> Int16# -> Int#+leInt16# a1 a2 = GHC.Internal.Prim.leInt16# a1 a2+{-# NOINLINE ltInt16# #-}+ltInt16# :: Int16# -> Int16# -> Int#+ltInt16# a1 a2 = GHC.Internal.Prim.ltInt16# a1 a2+{-# NOINLINE neInt16# #-}+neInt16# :: Int16# -> Int16# -> Int#+neInt16# a1 a2 = GHC.Internal.Prim.neInt16# a1 a2+{-# NOINLINE word16ToWord# #-}+word16ToWord# :: Word16# -> Word#+word16ToWord# a1 = GHC.Internal.Prim.word16ToWord# a1+{-# NOINLINE wordToWord16# #-}+wordToWord16# :: Word# -> Word16#+wordToWord16# a1 = GHC.Internal.Prim.wordToWord16# a1+{-# NOINLINE plusWord16# #-}+plusWord16# :: Word16# -> Word16# -> Word16#+plusWord16# a1 a2 = GHC.Internal.Prim.plusWord16# a1 a2+{-# NOINLINE subWord16# #-}+subWord16# :: Word16# -> Word16# -> Word16#+subWord16# a1 a2 = GHC.Internal.Prim.subWord16# a1 a2+{-# NOINLINE timesWord16# #-}+timesWord16# :: Word16# -> Word16# -> Word16#+timesWord16# a1 a2 = GHC.Internal.Prim.timesWord16# a1 a2+{-# NOINLINE quotWord16# #-}+quotWord16# :: Word16# -> Word16# -> Word16#+quotWord16# a1 a2 = GHC.Internal.Prim.quotWord16# a1 a2+{-# NOINLINE remWord16# #-}+remWord16# :: Word16# -> Word16# -> Word16#+remWord16# a1 a2 = GHC.Internal.Prim.remWord16# a1 a2+{-# NOINLINE quotRemWord16# #-}+quotRemWord16# :: Word16# -> Word16# -> (# Word16#,Word16# #)+quotRemWord16# a1 a2 = GHC.Internal.Prim.quotRemWord16# a1 a2+{-# NOINLINE andWord16# #-}+andWord16# :: Word16# -> Word16# -> Word16#+andWord16# a1 a2 = GHC.Internal.Prim.andWord16# a1 a2+{-# NOINLINE orWord16# #-}+orWord16# :: Word16# -> Word16# -> Word16#+orWord16# a1 a2 = GHC.Internal.Prim.orWord16# a1 a2+{-# NOINLINE xorWord16# #-}+xorWord16# :: Word16# -> Word16# -> Word16#+xorWord16# a1 a2 = GHC.Internal.Prim.xorWord16# a1 a2+{-# NOINLINE notWord16# #-}+notWord16# :: Word16# -> Word16#+notWord16# a1 = GHC.Internal.Prim.notWord16# a1+{-# NOINLINE uncheckedShiftLWord16# #-}+uncheckedShiftLWord16# :: Word16# -> Int# -> Word16#+uncheckedShiftLWord16# a1 a2 = GHC.Internal.Prim.uncheckedShiftLWord16# a1 a2+{-# NOINLINE uncheckedShiftRLWord16# #-}+uncheckedShiftRLWord16# :: Word16# -> Int# -> Word16#+uncheckedShiftRLWord16# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLWord16# a1 a2+{-# NOINLINE word16ToInt16# #-}+word16ToInt16# :: Word16# -> Int16#+word16ToInt16# a1 = GHC.Internal.Prim.word16ToInt16# a1+{-# NOINLINE eqWord16# #-}+eqWord16# :: Word16# -> Word16# -> Int#+eqWord16# a1 a2 = GHC.Internal.Prim.eqWord16# a1 a2+{-# NOINLINE geWord16# #-}+geWord16# :: Word16# -> Word16# -> Int#+geWord16# a1 a2 = GHC.Internal.Prim.geWord16# a1 a2+{-# NOINLINE gtWord16# #-}+gtWord16# :: Word16# -> Word16# -> Int#+gtWord16# a1 a2 = GHC.Internal.Prim.gtWord16# a1 a2+{-# NOINLINE leWord16# #-}+leWord16# :: Word16# -> Word16# -> Int#+leWord16# a1 a2 = GHC.Internal.Prim.leWord16# a1 a2+{-# NOINLINE ltWord16# #-}+ltWord16# :: Word16# -> Word16# -> Int#+ltWord16# a1 a2 = GHC.Internal.Prim.ltWord16# a1 a2+{-# NOINLINE neWord16# #-}+neWord16# :: Word16# -> Word16# -> Int#+neWord16# a1 a2 = GHC.Internal.Prim.neWord16# a1 a2+{-# NOINLINE int32ToInt# #-}+int32ToInt# :: Int32# -> Int#+int32ToInt# a1 = GHC.Internal.Prim.int32ToInt# a1+{-# NOINLINE intToInt32# #-}+intToInt32# :: Int# -> Int32#+intToInt32# a1 = GHC.Internal.Prim.intToInt32# a1+{-# NOINLINE negateInt32# #-}+negateInt32# :: Int32# -> Int32#+negateInt32# a1 = GHC.Internal.Prim.negateInt32# a1+{-# NOINLINE plusInt32# #-}+plusInt32# :: Int32# -> Int32# -> Int32#+plusInt32# a1 a2 = GHC.Internal.Prim.plusInt32# a1 a2+{-# NOINLINE subInt32# #-}+subInt32# :: Int32# -> Int32# -> Int32#+subInt32# a1 a2 = GHC.Internal.Prim.subInt32# a1 a2+{-# NOINLINE timesInt32# #-}+timesInt32# :: Int32# -> Int32# -> Int32#+timesInt32# a1 a2 = GHC.Internal.Prim.timesInt32# a1 a2+{-# NOINLINE quotInt32# #-}+quotInt32# :: Int32# -> Int32# -> Int32#+quotInt32# a1 a2 = GHC.Internal.Prim.quotInt32# a1 a2+{-# NOINLINE remInt32# #-}+remInt32# :: Int32# -> Int32# -> Int32#+remInt32# a1 a2 = GHC.Internal.Prim.remInt32# a1 a2+{-# NOINLINE quotRemInt32# #-}+quotRemInt32# :: Int32# -> Int32# -> (# Int32#,Int32# #)+quotRemInt32# a1 a2 = GHC.Internal.Prim.quotRemInt32# a1 a2+{-# NOINLINE uncheckedShiftLInt32# #-}+uncheckedShiftLInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftLInt32# a1 a2 = GHC.Internal.Prim.uncheckedShiftLInt32# a1 a2+{-# NOINLINE uncheckedShiftRAInt32# #-}+uncheckedShiftRAInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftRAInt32# a1 a2 = GHC.Internal.Prim.uncheckedShiftRAInt32# a1 a2+{-# NOINLINE uncheckedShiftRLInt32# #-}+uncheckedShiftRLInt32# :: Int32# -> Int# -> Int32#+uncheckedShiftRLInt32# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLInt32# a1 a2+{-# NOINLINE int32ToWord32# #-}+int32ToWord32# :: Int32# -> Word32#+int32ToWord32# a1 = GHC.Internal.Prim.int32ToWord32# a1+{-# NOINLINE eqInt32# #-}+eqInt32# :: Int32# -> Int32# -> Int#+eqInt32# a1 a2 = GHC.Internal.Prim.eqInt32# a1 a2+{-# NOINLINE geInt32# #-}+geInt32# :: Int32# -> Int32# -> Int#+geInt32# a1 a2 = GHC.Internal.Prim.geInt32# a1 a2+{-# NOINLINE gtInt32# #-}+gtInt32# :: Int32# -> Int32# -> Int#+gtInt32# a1 a2 = GHC.Internal.Prim.gtInt32# a1 a2+{-# NOINLINE leInt32# #-}+leInt32# :: Int32# -> Int32# -> Int#+leInt32# a1 a2 = GHC.Internal.Prim.leInt32# a1 a2+{-# NOINLINE ltInt32# #-}+ltInt32# :: Int32# -> Int32# -> Int#+ltInt32# a1 a2 = GHC.Internal.Prim.ltInt32# a1 a2+{-# NOINLINE neInt32# #-}+neInt32# :: Int32# -> Int32# -> Int#+neInt32# a1 a2 = GHC.Internal.Prim.neInt32# a1 a2+{-# NOINLINE word32ToWord# #-}+word32ToWord# :: Word32# -> Word#+word32ToWord# a1 = GHC.Internal.Prim.word32ToWord# a1+{-# NOINLINE wordToWord32# #-}+wordToWord32# :: Word# -> Word32#+wordToWord32# a1 = GHC.Internal.Prim.wordToWord32# a1+{-# NOINLINE plusWord32# #-}+plusWord32# :: Word32# -> Word32# -> Word32#+plusWord32# a1 a2 = GHC.Internal.Prim.plusWord32# a1 a2+{-# NOINLINE subWord32# #-}+subWord32# :: Word32# -> Word32# -> Word32#+subWord32# a1 a2 = GHC.Internal.Prim.subWord32# a1 a2+{-# NOINLINE timesWord32# #-}+timesWord32# :: Word32# -> Word32# -> Word32#+timesWord32# a1 a2 = GHC.Internal.Prim.timesWord32# a1 a2+{-# NOINLINE quotWord32# #-}+quotWord32# :: Word32# -> Word32# -> Word32#+quotWord32# a1 a2 = GHC.Internal.Prim.quotWord32# a1 a2+{-# NOINLINE remWord32# #-}+remWord32# :: Word32# -> Word32# -> Word32#+remWord32# a1 a2 = GHC.Internal.Prim.remWord32# a1 a2+{-# NOINLINE quotRemWord32# #-}+quotRemWord32# :: Word32# -> Word32# -> (# Word32#,Word32# #)+quotRemWord32# a1 a2 = GHC.Internal.Prim.quotRemWord32# a1 a2+{-# NOINLINE andWord32# #-}+andWord32# :: Word32# -> Word32# -> Word32#+andWord32# a1 a2 = GHC.Internal.Prim.andWord32# a1 a2+{-# NOINLINE orWord32# #-}+orWord32# :: Word32# -> Word32# -> Word32#+orWord32# a1 a2 = GHC.Internal.Prim.orWord32# a1 a2+{-# NOINLINE xorWord32# #-}+xorWord32# :: Word32# -> Word32# -> Word32#+xorWord32# a1 a2 = GHC.Internal.Prim.xorWord32# a1 a2+{-# NOINLINE notWord32# #-}+notWord32# :: Word32# -> Word32#+notWord32# a1 = GHC.Internal.Prim.notWord32# a1+{-# NOINLINE uncheckedShiftLWord32# #-}+uncheckedShiftLWord32# :: Word32# -> Int# -> Word32#+uncheckedShiftLWord32# a1 a2 = GHC.Internal.Prim.uncheckedShiftLWord32# a1 a2+{-# NOINLINE uncheckedShiftRLWord32# #-}+uncheckedShiftRLWord32# :: Word32# -> Int# -> Word32#+uncheckedShiftRLWord32# a1 a2 = GHC.Internal.Prim.uncheckedShiftRLWord32# a1 a2+{-# NOINLINE word32ToInt32# #-}+word32ToInt32# :: Word32# -> Int32#+word32ToInt32# a1 = GHC.Internal.Prim.word32ToInt32# a1+{-# NOINLINE eqWord32# #-}+eqWord32# :: Word32# -> Word32# -> Int#+eqWord32# a1 a2 = GHC.Internal.Prim.eqWord32# a1 a2+{-# NOINLINE geWord32# #-}+geWord32# :: Word32# -> Word32# -> Int#+geWord32# a1 a2 = GHC.Internal.Prim.geWord32# a1 a2+{-# NOINLINE gtWord32# #-}+gtWord32# :: Word32# -> Word32# -> Int#+gtWord32# a1 a2 = GHC.Internal.Prim.gtWord32# a1 a2+{-# NOINLINE leWord32# #-}+leWord32# :: Word32# -> Word32# -> Int#+leWord32# a1 a2 = GHC.Internal.Prim.leWord32# a1 a2+{-# NOINLINE ltWord32# #-}+ltWord32# :: Word32# -> Word32# -> Int#+ltWord32# a1 a2 = GHC.Internal.Prim.ltWord32# a1 a2+{-# NOINLINE neWord32# #-}+neWord32# :: Word32# -> Word32# -> Int#+neWord32# a1 a2 = GHC.Internal.Prim.neWord32# a1 a2+{-# NOINLINE int64ToInt# #-}+int64ToInt# :: Int64# -> Int#+int64ToInt# a1 = GHC.Internal.Prim.int64ToInt# a1+{-# NOINLINE intToInt64# #-}+intToInt64# :: Int# -> Int64#+intToInt64# a1 = GHC.Internal.Prim.intToInt64# a1+{-# NOINLINE negateInt64# #-}+negateInt64# :: Int64# -> Int64#+negateInt64# a1 = GHC.Internal.Prim.negateInt64# a1+{-# NOINLINE plusInt64# #-}+plusInt64# :: Int64# -> Int64# -> Int64#+plusInt64# a1 a2 = GHC.Internal.Prim.plusInt64# a1 a2+{-# NOINLINE subInt64# #-}+subInt64# :: Int64# -> Int64# -> Int64#+subInt64# a1 a2 = GHC.Internal.Prim.subInt64# a1 a2+{-# NOINLINE timesInt64# #-}+timesInt64# :: Int64# -> Int64# -> Int64#+timesInt64# a1 a2 = GHC.Internal.Prim.timesInt64# a1 a2+{-# NOINLINE quotInt64# #-}+quotInt64# :: Int64# -> Int64# -> Int64#+quotInt64# a1 a2 = GHC.Internal.Prim.quotInt64# a1 a2+{-# NOINLINE remInt64# #-}+remInt64# :: Int64# -> Int64# -> Int64#+remInt64# a1 a2 = GHC.Internal.Prim.remInt64# a1 a2+{-# NOINLINE uncheckedIShiftL64# #-}+uncheckedIShiftL64# :: Int64# -> Int# -> Int64#+uncheckedIShiftL64# a1 a2 = GHC.Internal.Prim.uncheckedIShiftL64# a1 a2+{-# NOINLINE uncheckedIShiftRA64# #-}+uncheckedIShiftRA64# :: Int64# -> Int# -> Int64#+uncheckedIShiftRA64# a1 a2 = GHC.Internal.Prim.uncheckedIShiftRA64# a1 a2+{-# NOINLINE uncheckedIShiftRL64# #-}+uncheckedIShiftRL64# :: Int64# -> Int# -> Int64#+uncheckedIShiftRL64# a1 a2 = GHC.Internal.Prim.uncheckedIShiftRL64# a1 a2+{-# NOINLINE int64ToWord64# #-}+int64ToWord64# :: Int64# -> Word64#+int64ToWord64# a1 = GHC.Internal.Prim.int64ToWord64# a1+{-# NOINLINE eqInt64# #-}+eqInt64# :: Int64# -> Int64# -> Int#+eqInt64# a1 a2 = GHC.Internal.Prim.eqInt64# a1 a2+{-# NOINLINE geInt64# #-}+geInt64# :: Int64# -> Int64# -> Int#+geInt64# a1 a2 = GHC.Internal.Prim.geInt64# a1 a2+{-# NOINLINE gtInt64# #-}+gtInt64# :: Int64# -> Int64# -> Int#+gtInt64# a1 a2 = GHC.Internal.Prim.gtInt64# a1 a2+{-# NOINLINE leInt64# #-}+leInt64# :: Int64# -> Int64# -> Int#+leInt64# a1 a2 = GHC.Internal.Prim.leInt64# a1 a2+{-# NOINLINE ltInt64# #-}+ltInt64# :: Int64# -> Int64# -> Int#+ltInt64# a1 a2 = GHC.Internal.Prim.ltInt64# a1 a2+{-# NOINLINE neInt64# #-}+neInt64# :: Int64# -> Int64# -> Int#+neInt64# a1 a2 = GHC.Internal.Prim.neInt64# a1 a2+{-# NOINLINE word64ToWord# #-}+word64ToWord# :: Word64# -> Word#+word64ToWord# a1 = GHC.Internal.Prim.word64ToWord# a1+{-# NOINLINE wordToWord64# #-}+wordToWord64# :: Word# -> Word64#+wordToWord64# a1 = GHC.Internal.Prim.wordToWord64# a1+{-# NOINLINE plusWord64# #-}+plusWord64# :: Word64# -> Word64# -> Word64#+plusWord64# a1 a2 = GHC.Internal.Prim.plusWord64# a1 a2+{-# NOINLINE subWord64# #-}+subWord64# :: Word64# -> Word64# -> Word64#+subWord64# a1 a2 = GHC.Internal.Prim.subWord64# a1 a2+{-# NOINLINE timesWord64# #-}+timesWord64# :: Word64# -> Word64# -> Word64#+timesWord64# a1 a2 = GHC.Internal.Prim.timesWord64# a1 a2+{-# NOINLINE quotWord64# #-}+quotWord64# :: Word64# -> Word64# -> Word64#+quotWord64# a1 a2 = GHC.Internal.Prim.quotWord64# a1 a2+{-# NOINLINE remWord64# #-}+remWord64# :: Word64# -> Word64# -> Word64#+remWord64# a1 a2 = GHC.Internal.Prim.remWord64# a1 a2+{-# NOINLINE and64# #-}+and64# :: Word64# -> Word64# -> Word64#+and64# a1 a2 = GHC.Internal.Prim.and64# a1 a2+{-# NOINLINE or64# #-}+or64# :: Word64# -> Word64# -> Word64#+or64# a1 a2 = GHC.Internal.Prim.or64# a1 a2+{-# NOINLINE xor64# #-}+xor64# :: Word64# -> Word64# -> Word64#+xor64# a1 a2 = GHC.Internal.Prim.xor64# a1 a2+{-# NOINLINE not64# #-}+not64# :: Word64# -> Word64#+not64# a1 = GHC.Internal.Prim.not64# a1+{-# NOINLINE uncheckedShiftL64# #-}+uncheckedShiftL64# :: Word64# -> Int# -> Word64#+uncheckedShiftL64# a1 a2 = GHC.Internal.Prim.uncheckedShiftL64# a1 a2+{-# NOINLINE uncheckedShiftRL64# #-}+uncheckedShiftRL64# :: Word64# -> Int# -> Word64#+uncheckedShiftRL64# a1 a2 = GHC.Internal.Prim.uncheckedShiftRL64# a1 a2+{-# NOINLINE word64ToInt64# #-}+word64ToInt64# :: Word64# -> Int64#+word64ToInt64# a1 = GHC.Internal.Prim.word64ToInt64# a1+{-# NOINLINE eqWord64# #-}+eqWord64# :: Word64# -> Word64# -> Int#+eqWord64# a1 a2 = GHC.Internal.Prim.eqWord64# a1 a2+{-# NOINLINE geWord64# #-}+geWord64# :: Word64# -> Word64# -> Int#+geWord64# a1 a2 = GHC.Internal.Prim.geWord64# a1 a2+{-# NOINLINE gtWord64# #-}+gtWord64# :: Word64# -> Word64# -> Int#+gtWord64# a1 a2 = GHC.Internal.Prim.gtWord64# a1 a2+{-# NOINLINE leWord64# #-}+leWord64# :: Word64# -> Word64# -> Int#+leWord64# a1 a2 = GHC.Internal.Prim.leWord64# a1 a2+{-# NOINLINE ltWord64# #-}+ltWord64# :: Word64# -> Word64# -> Int#+ltWord64# a1 a2 = GHC.Internal.Prim.ltWord64# a1 a2+{-# NOINLINE neWord64# #-}+neWord64# :: Word64# -> Word64# -> Int#+neWord64# a1 a2 = GHC.Internal.Prim.neWord64# a1 a2+{-# NOINLINE (+#) #-}+(+#) :: Int# -> Int# -> Int#+(+#) a1 a2 = (GHC.Internal.Prim.+#) a1 a2+{-# NOINLINE (-#) #-}+(-#) :: Int# -> Int# -> Int#+(-#) a1 a2 = (GHC.Internal.Prim.-#) a1 a2+{-# NOINLINE (*#) #-}+(*#) :: Int# -> Int# -> Int#+(*#) a1 a2 = (GHC.Internal.Prim.*#) a1 a2+{-# NOINLINE timesInt2# #-}+timesInt2# :: Int# -> Int# -> (# Int#,Int#,Int# #)+timesInt2# a1 a2 = GHC.Internal.Prim.timesInt2# a1 a2+{-# NOINLINE mulIntMayOflo# #-}+mulIntMayOflo# :: Int# -> Int# -> Int#+mulIntMayOflo# a1 a2 = GHC.Internal.Prim.mulIntMayOflo# a1 a2+{-# NOINLINE quotInt# #-}+quotInt# :: Int# -> Int# -> Int#+quotInt# a1 a2 = GHC.Internal.Prim.quotInt# a1 a2+{-# NOINLINE remInt# #-}+remInt# :: Int# -> Int# -> Int#+remInt# a1 a2 = GHC.Internal.Prim.remInt# a1 a2+{-# NOINLINE quotRemInt# #-}+quotRemInt# :: Int# -> Int# -> (# Int#,Int# #)+quotRemInt# a1 a2 = GHC.Internal.Prim.quotRemInt# a1 a2+{-# NOINLINE andI# #-}+andI# :: Int# -> Int# -> Int#+andI# a1 a2 = GHC.Internal.Prim.andI# a1 a2+{-# NOINLINE orI# #-}+orI# :: Int# -> Int# -> Int#+orI# a1 a2 = GHC.Internal.Prim.orI# a1 a2+{-# NOINLINE xorI# #-}+xorI# :: Int# -> Int# -> Int#+xorI# a1 a2 = GHC.Internal.Prim.xorI# a1 a2+{-# NOINLINE notI# #-}+notI# :: Int# -> Int#+notI# a1 = GHC.Internal.Prim.notI# a1+{-# NOINLINE negateInt# #-}+negateInt# :: Int# -> Int#+negateInt# a1 = GHC.Internal.Prim.negateInt# a1+{-# NOINLINE addIntC# #-}+addIntC# :: Int# -> Int# -> (# Int#,Int# #)+addIntC# a1 a2 = GHC.Internal.Prim.addIntC# a1 a2+{-# NOINLINE subIntC# #-}+subIntC# :: Int# -> Int# -> (# Int#,Int# #)+subIntC# a1 a2 = GHC.Internal.Prim.subIntC# a1 a2+{-# NOINLINE (>#) #-}+(>#) :: Int# -> Int# -> Int#+(>#) a1 a2 = (GHC.Internal.Prim.>#) a1 a2+{-# NOINLINE (>=#) #-}+(>=#) :: Int# -> Int# -> Int#+(>=#) a1 a2 = (GHC.Internal.Prim.>=#) a1 a2+{-# NOINLINE (==#) #-}+(==#) :: Int# -> Int# -> Int#+(==#) a1 a2 = (GHC.Internal.Prim.==#) a1 a2+{-# NOINLINE (/=#) #-}+(/=#) :: Int# -> Int# -> Int#+(/=#) a1 a2 = (GHC.Internal.Prim./=#) a1 a2+{-# NOINLINE (<#) #-}+(<#) :: Int# -> Int# -> Int#+(<#) a1 a2 = (GHC.Internal.Prim.<#) a1 a2+{-# NOINLINE (<=#) #-}+(<=#) :: Int# -> Int# -> Int#+(<=#) a1 a2 = (GHC.Internal.Prim.<=#) a1 a2+{-# NOINLINE chr# #-}+chr# :: Int# -> Char#+chr# a1 = GHC.Internal.Prim.chr# a1+{-# NOINLINE int2Word# #-}+int2Word# :: Int# -> Word#+int2Word# a1 = GHC.Internal.Prim.int2Word# a1+{-# NOINLINE int2Float# #-}+int2Float# :: Int# -> Float#+int2Float# a1 = GHC.Internal.Prim.int2Float# a1+{-# NOINLINE int2Double# #-}+int2Double# :: Int# -> Double#+int2Double# a1 = GHC.Internal.Prim.int2Double# a1+{-# NOINLINE word2Float# #-}+word2Float# :: Word# -> Float#+word2Float# a1 = GHC.Internal.Prim.word2Float# a1+{-# NOINLINE word2Double# #-}+word2Double# :: Word# -> Double#+word2Double# a1 = GHC.Internal.Prim.word2Double# a1+{-# NOINLINE uncheckedIShiftL# #-}+uncheckedIShiftL# :: Int# -> Int# -> Int#+uncheckedIShiftL# a1 a2 = GHC.Internal.Prim.uncheckedIShiftL# a1 a2+{-# NOINLINE uncheckedIShiftRA# #-}+uncheckedIShiftRA# :: Int# -> Int# -> Int#+uncheckedIShiftRA# a1 a2 = GHC.Internal.Prim.uncheckedIShiftRA# a1 a2+{-# NOINLINE uncheckedIShiftRL# #-}+uncheckedIShiftRL# :: Int# -> Int# -> Int#+uncheckedIShiftRL# a1 a2 = GHC.Internal.Prim.uncheckedIShiftRL# a1 a2+{-# NOINLINE plusWord# #-}+plusWord# :: Word# -> Word# -> Word#+plusWord# a1 a2 = GHC.Internal.Prim.plusWord# a1 a2+{-# NOINLINE addWordC# #-}+addWordC# :: Word# -> Word# -> (# Word#,Int# #)+addWordC# a1 a2 = GHC.Internal.Prim.addWordC# a1 a2+{-# NOINLINE subWordC# #-}+subWordC# :: Word# -> Word# -> (# Word#,Int# #)+subWordC# a1 a2 = GHC.Internal.Prim.subWordC# a1 a2+{-# NOINLINE plusWord2# #-}+plusWord2# :: Word# -> Word# -> (# Word#,Word# #)+plusWord2# a1 a2 = GHC.Internal.Prim.plusWord2# a1 a2+{-# NOINLINE minusWord# #-}+minusWord# :: Word# -> Word# -> Word#+minusWord# a1 a2 = GHC.Internal.Prim.minusWord# a1 a2+{-# NOINLINE timesWord# #-}+timesWord# :: Word# -> Word# -> Word#+timesWord# a1 a2 = GHC.Internal.Prim.timesWord# a1 a2+{-# NOINLINE timesWord2# #-}+timesWord2# :: Word# -> Word# -> (# Word#,Word# #)+timesWord2# a1 a2 = GHC.Internal.Prim.timesWord2# a1 a2+{-# NOINLINE quotWord# #-}+quotWord# :: Word# -> Word# -> Word#+quotWord# a1 a2 = GHC.Internal.Prim.quotWord# a1 a2+{-# NOINLINE remWord# #-}+remWord# :: Word# -> Word# -> Word#+remWord# a1 a2 = GHC.Internal.Prim.remWord# a1 a2+{-# NOINLINE quotRemWord# #-}+quotRemWord# :: Word# -> Word# -> (# Word#,Word# #)+quotRemWord# a1 a2 = GHC.Internal.Prim.quotRemWord# a1 a2+{-# NOINLINE quotRemWord2# #-}+quotRemWord2# :: Word# -> Word# -> Word# -> (# Word#,Word# #)+quotRemWord2# a1 a2 a3 = GHC.Internal.Prim.quotRemWord2# a1 a2 a3+{-# NOINLINE and# #-}+and# :: Word# -> Word# -> Word#+and# a1 a2 = GHC.Internal.Prim.and# a1 a2+{-# NOINLINE or# #-}+or# :: Word# -> Word# -> Word#+or# a1 a2 = GHC.Internal.Prim.or# a1 a2+{-# NOINLINE xor# #-}+xor# :: Word# -> Word# -> Word#+xor# a1 a2 = GHC.Internal.Prim.xor# a1 a2+{-# NOINLINE not# #-}+not# :: Word# -> Word#+not# a1 = GHC.Internal.Prim.not# a1+{-# NOINLINE uncheckedShiftL# #-}+uncheckedShiftL# :: Word# -> Int# -> Word#+uncheckedShiftL# a1 a2 = GHC.Internal.Prim.uncheckedShiftL# a1 a2+{-# NOINLINE uncheckedShiftRL# #-}+uncheckedShiftRL# :: Word# -> Int# -> Word#+uncheckedShiftRL# a1 a2 = GHC.Internal.Prim.uncheckedShiftRL# a1 a2+{-# NOINLINE word2Int# #-}+word2Int# :: Word# -> Int#+word2Int# a1 = GHC.Internal.Prim.word2Int# a1+{-# NOINLINE gtWord# #-}+gtWord# :: Word# -> Word# -> Int#+gtWord# a1 a2 = GHC.Internal.Prim.gtWord# a1 a2+{-# NOINLINE geWord# #-}+geWord# :: Word# -> Word# -> Int#+geWord# a1 a2 = GHC.Internal.Prim.geWord# a1 a2+{-# NOINLINE eqWord# #-}+eqWord# :: Word# -> Word# -> Int#+eqWord# a1 a2 = GHC.Internal.Prim.eqWord# a1 a2+{-# NOINLINE neWord# #-}+neWord# :: Word# -> Word# -> Int#+neWord# a1 a2 = GHC.Internal.Prim.neWord# a1 a2+{-# NOINLINE ltWord# #-}+ltWord# :: Word# -> Word# -> Int#+ltWord# a1 a2 = GHC.Internal.Prim.ltWord# a1 a2+{-# NOINLINE leWord# #-}+leWord# :: Word# -> Word# -> Int#+leWord# a1 a2 = GHC.Internal.Prim.leWord# a1 a2+{-# NOINLINE popCnt8# #-}+popCnt8# :: Word# -> Word#+popCnt8# a1 = GHC.Internal.Prim.popCnt8# a1+{-# NOINLINE popCnt16# #-}+popCnt16# :: Word# -> Word#+popCnt16# a1 = GHC.Internal.Prim.popCnt16# a1+{-# NOINLINE popCnt32# #-}+popCnt32# :: Word# -> Word#+popCnt32# a1 = GHC.Internal.Prim.popCnt32# a1+{-# NOINLINE popCnt64# #-}+popCnt64# :: Word64# -> Word#+popCnt64# a1 = GHC.Internal.Prim.popCnt64# a1+{-# NOINLINE popCnt# #-}+popCnt# :: Word# -> Word#+popCnt# a1 = GHC.Internal.Prim.popCnt# a1+{-# NOINLINE pdep8# #-}+pdep8# :: Word# -> Word# -> Word#+pdep8# a1 a2 = GHC.Internal.Prim.pdep8# a1 a2+{-# NOINLINE pdep16# #-}+pdep16# :: Word# -> Word# -> Word#+pdep16# a1 a2 = GHC.Internal.Prim.pdep16# a1 a2+{-# NOINLINE pdep32# #-}+pdep32# :: Word# -> Word# -> Word#+pdep32# a1 a2 = GHC.Internal.Prim.pdep32# a1 a2+{-# NOINLINE pdep64# #-}+pdep64# :: Word64# -> Word64# -> Word64#+pdep64# a1 a2 = GHC.Internal.Prim.pdep64# a1 a2+{-# NOINLINE pdep# #-}+pdep# :: Word# -> Word# -> Word#+pdep# a1 a2 = GHC.Internal.Prim.pdep# a1 a2+{-# NOINLINE pext8# #-}+pext8# :: Word# -> Word# -> Word#+pext8# a1 a2 = GHC.Internal.Prim.pext8# a1 a2+{-# NOINLINE pext16# #-}+pext16# :: Word# -> Word# -> Word#+pext16# a1 a2 = GHC.Internal.Prim.pext16# a1 a2+{-# NOINLINE pext32# #-}+pext32# :: Word# -> Word# -> Word#+pext32# a1 a2 = GHC.Internal.Prim.pext32# a1 a2+{-# NOINLINE pext64# #-}+pext64# :: Word64# -> Word64# -> Word64#+pext64# a1 a2 = GHC.Internal.Prim.pext64# a1 a2+{-# NOINLINE pext# #-}+pext# :: Word# -> Word# -> Word#+pext# a1 a2 = GHC.Internal.Prim.pext# a1 a2+{-# NOINLINE clz8# #-}+clz8# :: Word# -> Word#+clz8# a1 = GHC.Internal.Prim.clz8# a1+{-# NOINLINE clz16# #-}+clz16# :: Word# -> Word#+clz16# a1 = GHC.Internal.Prim.clz16# a1+{-# NOINLINE clz32# #-}+clz32# :: Word# -> Word#+clz32# a1 = GHC.Internal.Prim.clz32# a1+{-# NOINLINE clz64# #-}+clz64# :: Word64# -> Word#+clz64# a1 = GHC.Internal.Prim.clz64# a1+{-# NOINLINE clz# #-}+clz# :: Word# -> Word#+clz# a1 = GHC.Internal.Prim.clz# a1+{-# NOINLINE ctz8# #-}+ctz8# :: Word# -> Word#+ctz8# a1 = GHC.Internal.Prim.ctz8# a1+{-# NOINLINE ctz16# #-}+ctz16# :: Word# -> Word#+ctz16# a1 = GHC.Internal.Prim.ctz16# a1+{-# NOINLINE ctz32# #-}+ctz32# :: Word# -> Word#+ctz32# a1 = GHC.Internal.Prim.ctz32# a1+{-# NOINLINE ctz64# #-}+ctz64# :: Word64# -> Word#+ctz64# a1 = GHC.Internal.Prim.ctz64# a1+{-# NOINLINE ctz# #-}+ctz# :: Word# -> Word#+ctz# a1 = GHC.Internal.Prim.ctz# a1+{-# NOINLINE byteSwap16# #-}+byteSwap16# :: Word# -> Word#+byteSwap16# a1 = GHC.Internal.Prim.byteSwap16# a1+{-# NOINLINE byteSwap32# #-}+byteSwap32# :: Word# -> Word#+byteSwap32# a1 = GHC.Internal.Prim.byteSwap32# a1+{-# NOINLINE byteSwap64# #-}+byteSwap64# :: Word64# -> Word64#+byteSwap64# a1 = GHC.Internal.Prim.byteSwap64# a1+{-# NOINLINE byteSwap# #-}+byteSwap# :: Word# -> Word#+byteSwap# a1 = GHC.Internal.Prim.byteSwap# a1+{-# NOINLINE bitReverse8# #-}+bitReverse8# :: Word# -> Word#+bitReverse8# a1 = GHC.Internal.Prim.bitReverse8# a1+{-# NOINLINE bitReverse16# #-}+bitReverse16# :: Word# -> Word#+bitReverse16# a1 = GHC.Internal.Prim.bitReverse16# a1+{-# NOINLINE bitReverse32# #-}+bitReverse32# :: Word# -> Word#+bitReverse32# a1 = GHC.Internal.Prim.bitReverse32# a1+{-# NOINLINE bitReverse64# #-}+bitReverse64# :: Word64# -> Word64#+bitReverse64# a1 = GHC.Internal.Prim.bitReverse64# a1+{-# NOINLINE bitReverse# #-}+bitReverse# :: Word# -> Word#+bitReverse# a1 = GHC.Internal.Prim.bitReverse# a1+{-# NOINLINE narrow8Int# #-}+narrow8Int# :: Int# -> Int#+narrow8Int# a1 = GHC.Internal.Prim.narrow8Int# a1+{-# NOINLINE narrow16Int# #-}+narrow16Int# :: Int# -> Int#+narrow16Int# a1 = GHC.Internal.Prim.narrow16Int# a1+{-# NOINLINE narrow32Int# #-}+narrow32Int# :: Int# -> Int#+narrow32Int# a1 = GHC.Internal.Prim.narrow32Int# a1+{-# NOINLINE narrow8Word# #-}+narrow8Word# :: Word# -> Word#+narrow8Word# a1 = GHC.Internal.Prim.narrow8Word# a1+{-# NOINLINE narrow16Word# #-}+narrow16Word# :: Word# -> Word#+narrow16Word# a1 = GHC.Internal.Prim.narrow16Word# a1+{-# NOINLINE narrow32Word# #-}+narrow32Word# :: Word# -> Word#+narrow32Word# a1 = GHC.Internal.Prim.narrow32Word# a1+{-# NOINLINE (>##) #-}+(>##) :: Double# -> Double# -> Int#+(>##) a1 a2 = (GHC.Internal.Prim.>##) a1 a2+{-# NOINLINE (>=##) #-}+(>=##) :: Double# -> Double# -> Int#+(>=##) a1 a2 = (GHC.Internal.Prim.>=##) a1 a2+{-# NOINLINE (==##) #-}+(==##) :: Double# -> Double# -> Int#+(==##) a1 a2 = (GHC.Internal.Prim.==##) a1 a2+{-# NOINLINE (/=##) #-}+(/=##) :: Double# -> Double# -> Int#+(/=##) a1 a2 = (GHC.Internal.Prim./=##) a1 a2+{-# NOINLINE (<##) #-}+(<##) :: Double# -> Double# -> Int#+(<##) a1 a2 = (GHC.Internal.Prim.<##) a1 a2+{-# NOINLINE (<=##) #-}+(<=##) :: Double# -> Double# -> Int#+(<=##) a1 a2 = (GHC.Internal.Prim.<=##) a1 a2+{-# NOINLINE minDouble# #-}+minDouble# :: Double# -> Double# -> Double#+minDouble# a1 a2 = GHC.Internal.Prim.minDouble# a1 a2+{-# NOINLINE maxDouble# #-}+maxDouble# :: Double# -> Double# -> Double#+maxDouble# a1 a2 = GHC.Internal.Prim.maxDouble# a1 a2+{-# NOINLINE (+##) #-}+(+##) :: Double# -> Double# -> Double#+(+##) a1 a2 = (GHC.Internal.Prim.+##) a1 a2+{-# NOINLINE (-##) #-}+(-##) :: Double# -> Double# -> Double#+(-##) a1 a2 = (GHC.Internal.Prim.-##) a1 a2+{-# NOINLINE (*##) #-}+(*##) :: Double# -> Double# -> Double#+(*##) a1 a2 = (GHC.Internal.Prim.*##) a1 a2+{-# NOINLINE (/##) #-}+(/##) :: Double# -> Double# -> Double#+(/##) a1 a2 = (GHC.Internal.Prim./##) a1 a2+{-# NOINLINE negateDouble# #-}+negateDouble# :: Double# -> Double#+negateDouble# a1 = GHC.Internal.Prim.negateDouble# a1+{-# NOINLINE fabsDouble# #-}+fabsDouble# :: Double# -> Double#+fabsDouble# a1 = GHC.Internal.Prim.fabsDouble# a1+{-# NOINLINE double2Int# #-}+double2Int# :: Double# -> Int#+double2Int# a1 = GHC.Internal.Prim.double2Int# a1+{-# NOINLINE double2Float# #-}+double2Float# :: Double# -> Float#+double2Float# a1 = GHC.Internal.Prim.double2Float# a1+{-# NOINLINE expDouble# #-}+expDouble# :: Double# -> Double#+expDouble# a1 = GHC.Internal.Prim.expDouble# a1+{-# NOINLINE expm1Double# #-}+expm1Double# :: Double# -> Double#+expm1Double# a1 = GHC.Internal.Prim.expm1Double# a1+{-# NOINLINE logDouble# #-}+logDouble# :: Double# -> Double#+logDouble# a1 = GHC.Internal.Prim.logDouble# a1+{-# NOINLINE log1pDouble# #-}+log1pDouble# :: Double# -> Double#+log1pDouble# a1 = GHC.Internal.Prim.log1pDouble# a1+{-# NOINLINE sqrtDouble# #-}+sqrtDouble# :: Double# -> Double#+sqrtDouble# a1 = GHC.Internal.Prim.sqrtDouble# a1+{-# NOINLINE sinDouble# #-}+sinDouble# :: Double# -> Double#+sinDouble# a1 = GHC.Internal.Prim.sinDouble# a1+{-# NOINLINE cosDouble# #-}+cosDouble# :: Double# -> Double#+cosDouble# a1 = GHC.Internal.Prim.cosDouble# a1+{-# NOINLINE tanDouble# #-}+tanDouble# :: Double# -> Double#+tanDouble# a1 = GHC.Internal.Prim.tanDouble# a1+{-# NOINLINE asinDouble# #-}+asinDouble# :: Double# -> Double#+asinDouble# a1 = GHC.Internal.Prim.asinDouble# a1+{-# NOINLINE acosDouble# #-}+acosDouble# :: Double# -> Double#+acosDouble# a1 = GHC.Internal.Prim.acosDouble# a1+{-# NOINLINE atanDouble# #-}+atanDouble# :: Double# -> Double#+atanDouble# a1 = GHC.Internal.Prim.atanDouble# a1+{-# NOINLINE sinhDouble# #-}+sinhDouble# :: Double# -> Double#+sinhDouble# a1 = GHC.Internal.Prim.sinhDouble# a1+{-# NOINLINE coshDouble# #-}+coshDouble# :: Double# -> Double#+coshDouble# a1 = GHC.Internal.Prim.coshDouble# a1+{-# NOINLINE tanhDouble# #-}+tanhDouble# :: Double# -> Double#+tanhDouble# a1 = GHC.Internal.Prim.tanhDouble# a1+{-# NOINLINE asinhDouble# #-}+asinhDouble# :: Double# -> Double#+asinhDouble# a1 = GHC.Internal.Prim.asinhDouble# a1+{-# NOINLINE acoshDouble# #-}+acoshDouble# :: Double# -> Double#+acoshDouble# a1 = GHC.Internal.Prim.acoshDouble# a1+{-# NOINLINE atanhDouble# #-}+atanhDouble# :: Double# -> Double#+atanhDouble# a1 = GHC.Internal.Prim.atanhDouble# a1+{-# NOINLINE (**##) #-}+(**##) :: Double# -> Double# -> Double#+(**##) a1 a2 = (GHC.Internal.Prim.**##) a1 a2+{-# NOINLINE decodeDouble_2Int# #-}+decodeDouble_2Int# :: Double# -> (# Int#,Word#,Word#,Int# #)+decodeDouble_2Int# a1 = GHC.Internal.Prim.decodeDouble_2Int# a1+{-# NOINLINE decodeDouble_Int64# #-}+decodeDouble_Int64# :: Double# -> (# Int64#,Int# #)+decodeDouble_Int64# a1 = GHC.Internal.Prim.decodeDouble_Int64# a1+{-# NOINLINE castDoubleToWord64# #-}+castDoubleToWord64# :: Double# -> Word64#+castDoubleToWord64# a1 = GHC.Internal.Prim.castDoubleToWord64# a1+{-# NOINLINE castWord64ToDouble# #-}+castWord64ToDouble# :: Word64# -> Double#+castWord64ToDouble# a1 = GHC.Internal.Prim.castWord64ToDouble# a1+{-# NOINLINE gtFloat# #-}+gtFloat# :: Float# -> Float# -> Int#+gtFloat# a1 a2 = GHC.Internal.Prim.gtFloat# a1 a2+{-# NOINLINE geFloat# #-}+geFloat# :: Float# -> Float# -> Int#+geFloat# a1 a2 = GHC.Internal.Prim.geFloat# a1 a2+{-# NOINLINE eqFloat# #-}+eqFloat# :: Float# -> Float# -> Int#+eqFloat# a1 a2 = GHC.Internal.Prim.eqFloat# a1 a2+{-# NOINLINE neFloat# #-}+neFloat# :: Float# -> Float# -> Int#+neFloat# a1 a2 = GHC.Internal.Prim.neFloat# a1 a2+{-# NOINLINE ltFloat# #-}+ltFloat# :: Float# -> Float# -> Int#+ltFloat# a1 a2 = GHC.Internal.Prim.ltFloat# a1 a2+{-# NOINLINE leFloat# #-}+leFloat# :: Float# -> Float# -> Int#+leFloat# a1 a2 = GHC.Internal.Prim.leFloat# a1 a2+{-# NOINLINE minFloat# #-}+minFloat# :: Float# -> Float# -> Float#+minFloat# a1 a2 = GHC.Internal.Prim.minFloat# a1 a2+{-# NOINLINE maxFloat# #-}+maxFloat# :: Float# -> Float# -> Float#+maxFloat# a1 a2 = GHC.Internal.Prim.maxFloat# a1 a2+{-# NOINLINE plusFloat# #-}+plusFloat# :: Float# -> Float# -> Float#+plusFloat# a1 a2 = GHC.Internal.Prim.plusFloat# a1 a2+{-# NOINLINE minusFloat# #-}+minusFloat# :: Float# -> Float# -> Float#+minusFloat# a1 a2 = GHC.Internal.Prim.minusFloat# a1 a2+{-# NOINLINE timesFloat# #-}+timesFloat# :: Float# -> Float# -> Float#+timesFloat# a1 a2 = GHC.Internal.Prim.timesFloat# a1 a2+{-# NOINLINE divideFloat# #-}+divideFloat# :: Float# -> Float# -> Float#+divideFloat# a1 a2 = GHC.Internal.Prim.divideFloat# a1 a2+{-# NOINLINE negateFloat# #-}+negateFloat# :: Float# -> Float#+negateFloat# a1 = GHC.Internal.Prim.negateFloat# a1+{-# NOINLINE fabsFloat# #-}+fabsFloat# :: Float# -> Float#+fabsFloat# a1 = GHC.Internal.Prim.fabsFloat# a1+{-# NOINLINE float2Int# #-}+float2Int# :: Float# -> Int#+float2Int# a1 = GHC.Internal.Prim.float2Int# a1+{-# NOINLINE expFloat# #-}+expFloat# :: Float# -> Float#+expFloat# a1 = GHC.Internal.Prim.expFloat# a1+{-# NOINLINE expm1Float# #-}+expm1Float# :: Float# -> Float#+expm1Float# a1 = GHC.Internal.Prim.expm1Float# a1+{-# NOINLINE logFloat# #-}+logFloat# :: Float# -> Float#+logFloat# a1 = GHC.Internal.Prim.logFloat# a1+{-# NOINLINE log1pFloat# #-}+log1pFloat# :: Float# -> Float#+log1pFloat# a1 = GHC.Internal.Prim.log1pFloat# a1+{-# NOINLINE sqrtFloat# #-}+sqrtFloat# :: Float# -> Float#+sqrtFloat# a1 = GHC.Internal.Prim.sqrtFloat# a1+{-# NOINLINE sinFloat# #-}+sinFloat# :: Float# -> Float#+sinFloat# a1 = GHC.Internal.Prim.sinFloat# a1+{-# NOINLINE cosFloat# #-}+cosFloat# :: Float# -> Float#+cosFloat# a1 = GHC.Internal.Prim.cosFloat# a1+{-# NOINLINE tanFloat# #-}+tanFloat# :: Float# -> Float#+tanFloat# a1 = GHC.Internal.Prim.tanFloat# a1+{-# NOINLINE asinFloat# #-}+asinFloat# :: Float# -> Float#+asinFloat# a1 = GHC.Internal.Prim.asinFloat# a1+{-# NOINLINE acosFloat# #-}+acosFloat# :: Float# -> Float#+acosFloat# a1 = GHC.Internal.Prim.acosFloat# a1+{-# NOINLINE atanFloat# #-}+atanFloat# :: Float# -> Float#+atanFloat# a1 = GHC.Internal.Prim.atanFloat# a1+{-# NOINLINE sinhFloat# #-}+sinhFloat# :: Float# -> Float#+sinhFloat# a1 = GHC.Internal.Prim.sinhFloat# a1+{-# NOINLINE coshFloat# #-}+coshFloat# :: Float# -> Float#+coshFloat# a1 = GHC.Internal.Prim.coshFloat# a1+{-# NOINLINE tanhFloat# #-}+tanhFloat# :: Float# -> Float#+tanhFloat# a1 = GHC.Internal.Prim.tanhFloat# a1+{-# NOINLINE asinhFloat# #-}+asinhFloat# :: Float# -> Float#+asinhFloat# a1 = GHC.Internal.Prim.asinhFloat# a1+{-# NOINLINE acoshFloat# #-}+acoshFloat# :: Float# -> Float#+acoshFloat# a1 = GHC.Internal.Prim.acoshFloat# a1+{-# NOINLINE atanhFloat# #-}+atanhFloat# :: Float# -> Float#+atanhFloat# a1 = GHC.Internal.Prim.atanhFloat# a1+{-# NOINLINE powerFloat# #-}+powerFloat# :: Float# -> Float# -> Float#+powerFloat# a1 a2 = GHC.Internal.Prim.powerFloat# a1 a2+{-# NOINLINE float2Double# #-}+float2Double# :: Float# -> Double#+float2Double# a1 = GHC.Internal.Prim.float2Double# a1+{-# NOINLINE decodeFloat_Int# #-}+decodeFloat_Int# :: Float# -> (# Int#,Int# #)+decodeFloat_Int# a1 = GHC.Internal.Prim.decodeFloat_Int# a1+{-# NOINLINE castFloatToWord32# #-}+castFloatToWord32# :: Float# -> Word32#+castFloatToWord32# a1 = GHC.Internal.Prim.castFloatToWord32# a1+{-# NOINLINE castWord32ToFloat# #-}+castWord32ToFloat# :: Word32# -> Float#+castWord32ToFloat# a1 = GHC.Internal.Prim.castWord32ToFloat# a1+{-# NOINLINE fmaddFloat# #-}+fmaddFloat# :: Float# -> Float# -> Float# -> Float#+fmaddFloat# a1 a2 a3 = GHC.Internal.Prim.fmaddFloat# a1 a2 a3+{-# NOINLINE fmsubFloat# #-}+fmsubFloat# :: Float# -> Float# -> Float# -> Float#+fmsubFloat# a1 a2 a3 = GHC.Internal.Prim.fmsubFloat# a1 a2 a3+{-# NOINLINE fnmaddFloat# #-}+fnmaddFloat# :: Float# -> Float# -> Float# -> Float#+fnmaddFloat# a1 a2 a3 = GHC.Internal.Prim.fnmaddFloat# a1 a2 a3+{-# NOINLINE fnmsubFloat# #-}+fnmsubFloat# :: Float# -> Float# -> Float# -> Float#+fnmsubFloat# a1 a2 a3 = GHC.Internal.Prim.fnmsubFloat# a1 a2 a3+{-# NOINLINE fmaddDouble# #-}+fmaddDouble# :: Double# -> Double# -> Double# -> Double#+fmaddDouble# a1 a2 a3 = GHC.Internal.Prim.fmaddDouble# a1 a2 a3+{-# NOINLINE fmsubDouble# #-}+fmsubDouble# :: Double# -> Double# -> Double# -> Double#+fmsubDouble# a1 a2 a3 = GHC.Internal.Prim.fmsubDouble# a1 a2 a3+{-# NOINLINE fnmaddDouble# #-}+fnmaddDouble# :: Double# -> Double# -> Double# -> Double#+fnmaddDouble# a1 a2 a3 = GHC.Internal.Prim.fnmaddDouble# a1 a2 a3+{-# NOINLINE fnmsubDouble# #-}+fnmsubDouble# :: Double# -> Double# -> Double# -> Double#+fnmsubDouble# a1 a2 a3 = GHC.Internal.Prim.fnmsubDouble# a1 a2 a3+{-# NOINLINE newArray# #-}+newArray# :: Int# -> a_levpoly -> State# s -> (# State# s,MutableArray# s a_levpoly #)+newArray# a1 a2 a3 = GHC.Internal.Prim.newArray# a1 a2 a3+{-# NOINLINE readArray# #-}+readArray# :: MutableArray# s a_levpoly -> Int# -> State# s -> (# State# s,a_levpoly #)+readArray# a1 a2 a3 = GHC.Internal.Prim.readArray# a1 a2 a3+{-# NOINLINE writeArray# #-}+writeArray# :: MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+writeArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeArray# a1 a2 a3 a4+{-# NOINLINE sizeofArray# #-}+sizeofArray# :: Array# a_levpoly -> Int#+sizeofArray# a1 = GHC.Internal.Prim.sizeofArray# a1+{-# NOINLINE sizeofMutableArray# #-}+sizeofMutableArray# :: MutableArray# s a_levpoly -> Int#+sizeofMutableArray# a1 = GHC.Internal.Prim.sizeofMutableArray# a1+{-# NOINLINE indexArray# #-}+indexArray# :: Array# a_levpoly -> Int# -> (# a_levpoly #)+indexArray# a1 a2 = GHC.Internal.Prim.indexArray# a1 a2+{-# NOINLINE unsafeFreezeArray# #-}+unsafeFreezeArray# :: MutableArray# s a_levpoly -> State# s -> (# State# s,Array# a_levpoly #)+unsafeFreezeArray# a1 a2 = GHC.Internal.Prim.unsafeFreezeArray# a1 a2+{-# NOINLINE unsafeThawArray# #-}+unsafeThawArray# :: Array# a_levpoly -> State# s -> (# State# s,MutableArray# s a_levpoly #)+unsafeThawArray# a1 a2 = GHC.Internal.Prim.unsafeThawArray# a1 a2+{-# NOINLINE copyArray# #-}+copyArray# :: Array# a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copyArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE copyMutableArray# #-}+copyMutableArray# :: MutableArray# s a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copyMutableArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyMutableArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE cloneArray# #-}+cloneArray# :: Array# a_levpoly -> Int# -> Int# -> Array# a_levpoly+cloneArray# a1 a2 a3 = GHC.Internal.Prim.cloneArray# a1 a2 a3+{-# NOINLINE cloneMutableArray# #-}+cloneMutableArray# :: MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,MutableArray# s a_levpoly #)+cloneMutableArray# a1 a2 a3 a4 = GHC.Internal.Prim.cloneMutableArray# a1 a2 a3 a4+{-# NOINLINE freezeArray# #-}+freezeArray# :: MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,Array# a_levpoly #)+freezeArray# a1 a2 a3 a4 = GHC.Internal.Prim.freezeArray# a1 a2 a3 a4+{-# NOINLINE thawArray# #-}+thawArray# :: Array# a_levpoly -> Int# -> Int# -> State# s -> (# State# s,MutableArray# s a_levpoly #)+thawArray# a1 a2 a3 a4 = GHC.Internal.Prim.thawArray# a1 a2 a3 a4+{-# NOINLINE casArray# #-}+casArray# :: MutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casArray# a1 a2 a3 a4 a5+{-# NOINLINE newSmallArray# #-}+newSmallArray# :: Int# -> a_levpoly -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+newSmallArray# a1 a2 a3 = GHC.Internal.Prim.newSmallArray# a1 a2 a3+{-# NOINLINE shrinkSmallMutableArray# #-}+shrinkSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> State# s -> State# s+shrinkSmallMutableArray# a1 a2 a3 = GHC.Internal.Prim.shrinkSmallMutableArray# a1 a2 a3+{-# NOINLINE readSmallArray# #-}+readSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> State# s -> (# State# s,a_levpoly #)+readSmallArray# a1 a2 a3 = GHC.Internal.Prim.readSmallArray# a1 a2 a3+{-# NOINLINE writeSmallArray# #-}+writeSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+writeSmallArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeSmallArray# a1 a2 a3 a4+{-# NOINLINE sizeofSmallArray# #-}+sizeofSmallArray# :: SmallArray# a_levpoly -> Int#+sizeofSmallArray# a1 = GHC.Internal.Prim.sizeofSmallArray# a1+{-# NOINLINE sizeofSmallMutableArray# #-}+sizeofSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int#+sizeofSmallMutableArray# a1 = GHC.Internal.Prim.sizeofSmallMutableArray# a1+{-# NOINLINE getSizeofSmallMutableArray# #-}+getSizeofSmallMutableArray# :: SmallMutableArray# s a_levpoly -> State# s -> (# State# s,Int# #)+getSizeofSmallMutableArray# a1 a2 = GHC.Internal.Prim.getSizeofSmallMutableArray# a1 a2+{-# NOINLINE indexSmallArray# #-}+indexSmallArray# :: SmallArray# a_levpoly -> Int# -> (# a_levpoly #)+indexSmallArray# a1 a2 = GHC.Internal.Prim.indexSmallArray# a1 a2+{-# NOINLINE unsafeFreezeSmallArray# #-}+unsafeFreezeSmallArray# :: SmallMutableArray# s a_levpoly -> State# s -> (# State# s,SmallArray# a_levpoly #)+unsafeFreezeSmallArray# a1 a2 = GHC.Internal.Prim.unsafeFreezeSmallArray# a1 a2+{-# NOINLINE unsafeThawSmallArray# #-}+unsafeThawSmallArray# :: SmallArray# a_levpoly -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+unsafeThawSmallArray# a1 a2 = GHC.Internal.Prim.unsafeThawSmallArray# a1 a2+{-# NOINLINE copySmallArray# #-}+copySmallArray# :: SmallArray# a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copySmallArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copySmallArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE copySmallMutableArray# #-}+copySmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+copySmallMutableArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copySmallMutableArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE cloneSmallArray# #-}+cloneSmallArray# :: SmallArray# a_levpoly -> Int# -> Int# -> SmallArray# a_levpoly+cloneSmallArray# a1 a2 a3 = GHC.Internal.Prim.cloneSmallArray# a1 a2 a3+{-# NOINLINE cloneSmallMutableArray# #-}+cloneSmallMutableArray# :: SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+cloneSmallMutableArray# a1 a2 a3 a4 = GHC.Internal.Prim.cloneSmallMutableArray# a1 a2 a3 a4+{-# NOINLINE freezeSmallArray# #-}+freezeSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallArray# a_levpoly #)+freezeSmallArray# a1 a2 a3 a4 = GHC.Internal.Prim.freezeSmallArray# a1 a2 a3 a4+{-# NOINLINE thawSmallArray# #-}+thawSmallArray# :: SmallArray# a_levpoly -> Int# -> Int# -> State# s -> (# State# s,SmallMutableArray# s a_levpoly #)+thawSmallArray# a1 a2 a3 a4 = GHC.Internal.Prim.thawSmallArray# a1 a2 a3 a4+{-# NOINLINE casSmallArray# #-}+casSmallArray# :: SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casSmallArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casSmallArray# a1 a2 a3 a4 a5+{-# NOINLINE newByteArray# #-}+newByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newByteArray# a1 a2 = GHC.Internal.Prim.newByteArray# a1 a2+{-# NOINLINE newPinnedByteArray# #-}+newPinnedByteArray# :: Int# -> State# s -> (# State# s,MutableByteArray# s #)+newPinnedByteArray# a1 a2 = GHC.Internal.Prim.newPinnedByteArray# a1 a2+{-# NOINLINE newAlignedPinnedByteArray# #-}+newAlignedPinnedByteArray# :: Int# -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+newAlignedPinnedByteArray# a1 a2 a3 = GHC.Internal.Prim.newAlignedPinnedByteArray# a1 a2 a3+{-# NOINLINE isMutableByteArrayPinned# #-}+isMutableByteArrayPinned# :: MutableByteArray# s -> Int#+isMutableByteArrayPinned# a1 = GHC.Internal.Prim.isMutableByteArrayPinned# a1+{-# NOINLINE isByteArrayPinned# #-}+isByteArrayPinned# :: ByteArray# -> Int#+isByteArrayPinned# a1 = GHC.Internal.Prim.isByteArrayPinned# a1+{-# NOINLINE isByteArrayWeaklyPinned# #-}+isByteArrayWeaklyPinned# :: ByteArray# -> Int#+isByteArrayWeaklyPinned# a1 = GHC.Internal.Prim.isByteArrayWeaklyPinned# a1+{-# NOINLINE isMutableByteArrayWeaklyPinned# #-}+isMutableByteArrayWeaklyPinned# :: MutableByteArray# s -> Int#+isMutableByteArrayWeaklyPinned# a1 = GHC.Internal.Prim.isMutableByteArrayWeaklyPinned# a1+{-# NOINLINE byteArrayContents# #-}+byteArrayContents# :: ByteArray# -> Addr#+byteArrayContents# a1 = GHC.Internal.Prim.byteArrayContents# a1+{-# NOINLINE mutableByteArrayContents# #-}+mutableByteArrayContents# :: MutableByteArray# s -> Addr#+mutableByteArrayContents# a1 = GHC.Internal.Prim.mutableByteArrayContents# a1+{-# NOINLINE shrinkMutableByteArray# #-}+shrinkMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> State# s+shrinkMutableByteArray# a1 a2 a3 = GHC.Internal.Prim.shrinkMutableByteArray# a1 a2 a3+{-# NOINLINE resizeMutableByteArray# #-}+resizeMutableByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+resizeMutableByteArray# a1 a2 a3 = GHC.Internal.Prim.resizeMutableByteArray# a1 a2 a3+{-# NOINLINE unsafeFreezeByteArray# #-}+unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> (# State# s,ByteArray# #)+unsafeFreezeByteArray# a1 a2 = GHC.Internal.Prim.unsafeFreezeByteArray# a1 a2+{-# NOINLINE unsafeThawByteArray# #-}+unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s,MutableByteArray# s #)+unsafeThawByteArray# a1 a2 = GHC.Internal.Prim.unsafeThawByteArray# a1 a2+{-# NOINLINE sizeofByteArray# #-}+sizeofByteArray# :: ByteArray# -> Int#+sizeofByteArray# a1 = GHC.Internal.Prim.sizeofByteArray# a1+{-# NOINLINE sizeofMutableByteArray# #-}+sizeofMutableByteArray# :: MutableByteArray# s -> Int#+sizeofMutableByteArray# a1 = GHC.Internal.Prim.sizeofMutableByteArray# a1+{-# NOINLINE getSizeofMutableByteArray# #-}+getSizeofMutableByteArray# :: MutableByteArray# s -> State# s -> (# State# s,Int# #)+getSizeofMutableByteArray# a1 a2 = GHC.Internal.Prim.getSizeofMutableByteArray# a1 a2+{-# NOINLINE indexCharArray# #-}+indexCharArray# :: ByteArray# -> Int# -> Char#+indexCharArray# a1 a2 = GHC.Internal.Prim.indexCharArray# a1 a2+{-# NOINLINE indexWideCharArray# #-}+indexWideCharArray# :: ByteArray# -> Int# -> Char#+indexWideCharArray# a1 a2 = GHC.Internal.Prim.indexWideCharArray# a1 a2+{-# NOINLINE indexIntArray# #-}+indexIntArray# :: ByteArray# -> Int# -> Int#+indexIntArray# a1 a2 = GHC.Internal.Prim.indexIntArray# a1 a2+{-# NOINLINE indexWordArray# #-}+indexWordArray# :: ByteArray# -> Int# -> Word#+indexWordArray# a1 a2 = GHC.Internal.Prim.indexWordArray# a1 a2+{-# NOINLINE indexAddrArray# #-}+indexAddrArray# :: ByteArray# -> Int# -> Addr#+indexAddrArray# a1 a2 = GHC.Internal.Prim.indexAddrArray# a1 a2+{-# NOINLINE indexFloatArray# #-}+indexFloatArray# :: ByteArray# -> Int# -> Float#+indexFloatArray# a1 a2 = GHC.Internal.Prim.indexFloatArray# a1 a2+{-# NOINLINE indexDoubleArray# #-}+indexDoubleArray# :: ByteArray# -> Int# -> Double#+indexDoubleArray# a1 a2 = GHC.Internal.Prim.indexDoubleArray# a1 a2+{-# NOINLINE indexStablePtrArray# #-}+indexStablePtrArray# :: ByteArray# -> Int# -> StablePtr# a+indexStablePtrArray# a1 a2 = GHC.Internal.Prim.indexStablePtrArray# a1 a2+{-# NOINLINE indexInt8Array# #-}+indexInt8Array# :: ByteArray# -> Int# -> Int8#+indexInt8Array# a1 a2 = GHC.Internal.Prim.indexInt8Array# a1 a2+{-# NOINLINE indexWord8Array# #-}+indexWord8Array# :: ByteArray# -> Int# -> Word8#+indexWord8Array# a1 a2 = GHC.Internal.Prim.indexWord8Array# a1 a2+{-# NOINLINE indexInt16Array# #-}+indexInt16Array# :: ByteArray# -> Int# -> Int16#+indexInt16Array# a1 a2 = GHC.Internal.Prim.indexInt16Array# a1 a2+{-# NOINLINE indexWord16Array# #-}+indexWord16Array# :: ByteArray# -> Int# -> Word16#+indexWord16Array# a1 a2 = GHC.Internal.Prim.indexWord16Array# a1 a2+{-# NOINLINE indexInt32Array# #-}+indexInt32Array# :: ByteArray# -> Int# -> Int32#+indexInt32Array# a1 a2 = GHC.Internal.Prim.indexInt32Array# a1 a2+{-# NOINLINE indexWord32Array# #-}+indexWord32Array# :: ByteArray# -> Int# -> Word32#+indexWord32Array# a1 a2 = GHC.Internal.Prim.indexWord32Array# a1 a2+{-# NOINLINE indexInt64Array# #-}+indexInt64Array# :: ByteArray# -> Int# -> Int64#+indexInt64Array# a1 a2 = GHC.Internal.Prim.indexInt64Array# a1 a2+{-# NOINLINE indexWord64Array# #-}+indexWord64Array# :: ByteArray# -> Int# -> Word64#+indexWord64Array# a1 a2 = GHC.Internal.Prim.indexWord64Array# a1 a2+{-# NOINLINE indexWord8ArrayAsChar# #-}+indexWord8ArrayAsChar# :: ByteArray# -> Int# -> Char#+indexWord8ArrayAsChar# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsChar# a1 a2+{-# NOINLINE indexWord8ArrayAsWideChar# #-}+indexWord8ArrayAsWideChar# :: ByteArray# -> Int# -> Char#+indexWord8ArrayAsWideChar# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWideChar# a1 a2+{-# NOINLINE indexWord8ArrayAsInt# #-}+indexWord8ArrayAsInt# :: ByteArray# -> Int# -> Int#+indexWord8ArrayAsInt# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsInt# a1 a2+{-# NOINLINE indexWord8ArrayAsWord# #-}+indexWord8ArrayAsWord# :: ByteArray# -> Int# -> Word#+indexWord8ArrayAsWord# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWord# a1 a2+{-# NOINLINE indexWord8ArrayAsAddr# #-}+indexWord8ArrayAsAddr# :: ByteArray# -> Int# -> Addr#+indexWord8ArrayAsAddr# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsAddr# a1 a2+{-# NOINLINE indexWord8ArrayAsFloat# #-}+indexWord8ArrayAsFloat# :: ByteArray# -> Int# -> Float#+indexWord8ArrayAsFloat# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsFloat# a1 a2+{-# NOINLINE indexWord8ArrayAsDouble# #-}+indexWord8ArrayAsDouble# :: ByteArray# -> Int# -> Double#+indexWord8ArrayAsDouble# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsDouble# a1 a2+{-# NOINLINE indexWord8ArrayAsStablePtr# #-}+indexWord8ArrayAsStablePtr# :: ByteArray# -> Int# -> StablePtr# a+indexWord8ArrayAsStablePtr# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsStablePtr# a1 a2+{-# NOINLINE indexWord8ArrayAsInt16# #-}+indexWord8ArrayAsInt16# :: ByteArray# -> Int# -> Int16#+indexWord8ArrayAsInt16# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsInt16# a1 a2+{-# NOINLINE indexWord8ArrayAsWord16# #-}+indexWord8ArrayAsWord16# :: ByteArray# -> Int# -> Word16#+indexWord8ArrayAsWord16# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWord16# a1 a2+{-# NOINLINE indexWord8ArrayAsInt32# #-}+indexWord8ArrayAsInt32# :: ByteArray# -> Int# -> Int32#+indexWord8ArrayAsInt32# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsInt32# a1 a2+{-# NOINLINE indexWord8ArrayAsWord32# #-}+indexWord8ArrayAsWord32# :: ByteArray# -> Int# -> Word32#+indexWord8ArrayAsWord32# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWord32# a1 a2+{-# NOINLINE indexWord8ArrayAsInt64# #-}+indexWord8ArrayAsInt64# :: ByteArray# -> Int# -> Int64#+indexWord8ArrayAsInt64# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsInt64# a1 a2+{-# NOINLINE indexWord8ArrayAsWord64# #-}+indexWord8ArrayAsWord64# :: ByteArray# -> Int# -> Word64#+indexWord8ArrayAsWord64# a1 a2 = GHC.Internal.Prim.indexWord8ArrayAsWord64# a1 a2+{-# NOINLINE readCharArray# #-}+readCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readCharArray# a1 a2 a3 = GHC.Internal.Prim.readCharArray# a1 a2 a3+{-# NOINLINE readWideCharArray# #-}+readWideCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWideCharArray# a1 a2 a3 = GHC.Internal.Prim.readWideCharArray# a1 a2 a3+{-# NOINLINE readIntArray# #-}+readIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readIntArray# a1 a2 a3 = GHC.Internal.Prim.readIntArray# a1 a2 a3+{-# NOINLINE readWordArray# #-}+readWordArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWordArray# a1 a2 a3 = GHC.Internal.Prim.readWordArray# a1 a2 a3+{-# NOINLINE readAddrArray# #-}+readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readAddrArray# a1 a2 a3 = GHC.Internal.Prim.readAddrArray# a1 a2 a3+{-# NOINLINE readFloatArray# #-}+readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readFloatArray# a1 a2 a3 = GHC.Internal.Prim.readFloatArray# a1 a2 a3+{-# NOINLINE readDoubleArray# #-}+readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readDoubleArray# a1 a2 a3 = GHC.Internal.Prim.readDoubleArray# a1 a2 a3+{-# NOINLINE readStablePtrArray# #-}+readStablePtrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrArray# a1 a2 a3 = GHC.Internal.Prim.readStablePtrArray# a1 a2 a3+{-# NOINLINE readInt8Array# #-}+readInt8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int8# #)+readInt8Array# a1 a2 a3 = GHC.Internal.Prim.readInt8Array# a1 a2 a3+{-# NOINLINE readWord8Array# #-}+readWord8Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word8# #)+readWord8Array# a1 a2 a3 = GHC.Internal.Prim.readWord8Array# a1 a2 a3+{-# NOINLINE readInt16Array# #-}+readInt16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16# #)+readInt16Array# a1 a2 a3 = GHC.Internal.Prim.readInt16Array# a1 a2 a3+{-# NOINLINE readWord16Array# #-}+readWord16Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16# #)+readWord16Array# a1 a2 a3 = GHC.Internal.Prim.readWord16Array# a1 a2 a3+{-# NOINLINE readInt32Array# #-}+readInt32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32# #)+readInt32Array# a1 a2 a3 = GHC.Internal.Prim.readInt32Array# a1 a2 a3+{-# NOINLINE readWord32Array# #-}+readWord32Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32# #)+readWord32Array# a1 a2 a3 = GHC.Internal.Prim.readWord32Array# a1 a2 a3+{-# NOINLINE readInt64Array# #-}+readInt64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64# #)+readInt64Array# a1 a2 a3 = GHC.Internal.Prim.readInt64Array# a1 a2 a3+{-# NOINLINE readWord64Array# #-}+readWord64Array# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64# #)+readWord64Array# a1 a2 a3 = GHC.Internal.Prim.readWord64Array# a1 a2 a3+{-# NOINLINE readWord8ArrayAsChar# #-}+readWord8ArrayAsChar# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWord8ArrayAsChar# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsChar# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWideChar# #-}+readWord8ArrayAsWideChar# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #)+readWord8ArrayAsWideChar# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWideChar# a1 a2 a3+{-# NOINLINE readWord8ArrayAsInt# #-}+readWord8ArrayAsInt# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+readWord8ArrayAsInt# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsInt# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWord# #-}+readWord8ArrayAsWord# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word# #)+readWord8ArrayAsWord# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWord# a1 a2 a3+{-# NOINLINE readWord8ArrayAsAddr# #-}+readWord8ArrayAsAddr# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Addr# #)+readWord8ArrayAsAddr# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsAddr# a1 a2 a3+{-# NOINLINE readWord8ArrayAsFloat# #-}+readWord8ArrayAsFloat# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Float# #)+readWord8ArrayAsFloat# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsFloat# a1 a2 a3+{-# NOINLINE readWord8ArrayAsDouble# #-}+readWord8ArrayAsDouble# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Double# #)+readWord8ArrayAsDouble# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsDouble# a1 a2 a3+{-# NOINLINE readWord8ArrayAsStablePtr# #-}+readWord8ArrayAsStablePtr# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,StablePtr# a #)+readWord8ArrayAsStablePtr# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsStablePtr# a1 a2 a3+{-# NOINLINE readWord8ArrayAsInt16# #-}+readWord8ArrayAsInt16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int16# #)+readWord8ArrayAsInt16# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsInt16# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWord16# #-}+readWord8ArrayAsWord16# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word16# #)+readWord8ArrayAsWord16# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWord16# a1 a2 a3+{-# NOINLINE readWord8ArrayAsInt32# #-}+readWord8ArrayAsInt32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int32# #)+readWord8ArrayAsInt32# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsInt32# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWord32# #-}+readWord8ArrayAsWord32# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word32# #)+readWord8ArrayAsWord32# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWord32# a1 a2 a3+{-# NOINLINE readWord8ArrayAsInt64# #-}+readWord8ArrayAsInt64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int64# #)+readWord8ArrayAsInt64# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsInt64# a1 a2 a3+{-# NOINLINE readWord8ArrayAsWord64# #-}+readWord8ArrayAsWord64# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Word64# #)+readWord8ArrayAsWord64# a1 a2 a3 = GHC.Internal.Prim.readWord8ArrayAsWord64# a1 a2 a3+{-# NOINLINE writeCharArray# #-}+writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeCharArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeCharArray# a1 a2 a3 a4+{-# NOINLINE writeWideCharArray# #-}+writeWideCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWideCharArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeWideCharArray# a1 a2 a3 a4+{-# NOINLINE writeIntArray# #-}+writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeIntArray# a1 a2 a3 a4+{-# NOINLINE writeWordArray# #-}+writeWordArray# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWordArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeWordArray# a1 a2 a3 a4+{-# NOINLINE writeAddrArray# #-}+writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeAddrArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeAddrArray# a1 a2 a3 a4+{-# NOINLINE writeFloatArray# #-}+writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeFloatArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeFloatArray# a1 a2 a3 a4+{-# NOINLINE writeDoubleArray# #-}+writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeDoubleArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeDoubleArray# a1 a2 a3 a4+{-# NOINLINE writeStablePtrArray# #-}+writeStablePtrArray# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrArray# a1 a2 a3 a4 = GHC.Internal.Prim.writeStablePtrArray# a1 a2 a3 a4+{-# NOINLINE writeInt8Array# #-}+writeInt8Array# :: MutableByteArray# s -> Int# -> Int8# -> State# s -> State# s+writeInt8Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt8Array# a1 a2 a3 a4+{-# NOINLINE writeWord8Array# #-}+writeWord8Array# :: MutableByteArray# s -> Int# -> Word8# -> State# s -> State# s+writeWord8Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8Array# a1 a2 a3 a4+{-# NOINLINE writeInt16Array# #-}+writeInt16Array# :: MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+writeInt16Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt16Array# a1 a2 a3 a4+{-# NOINLINE writeWord16Array# #-}+writeWord16Array# :: MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+writeWord16Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord16Array# a1 a2 a3 a4+{-# NOINLINE writeInt32Array# #-}+writeInt32Array# :: MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+writeInt32Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt32Array# a1 a2 a3 a4+{-# NOINLINE writeWord32Array# #-}+writeWord32Array# :: MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+writeWord32Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord32Array# a1 a2 a3 a4+{-# NOINLINE writeInt64Array# #-}+writeInt64Array# :: MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+writeInt64Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt64Array# a1 a2 a3 a4+{-# NOINLINE writeWord64Array# #-}+writeWord64Array# :: MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+writeWord64Array# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord64Array# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsChar# #-}+writeWord8ArrayAsChar# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWord8ArrayAsChar# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsChar# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWideChar# #-}+writeWord8ArrayAsWideChar# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+writeWord8ArrayAsWideChar# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWideChar# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsInt# #-}+writeWord8ArrayAsInt# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+writeWord8ArrayAsInt# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsInt# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWord# #-}+writeWord8ArrayAsWord# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+writeWord8ArrayAsWord# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWord# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsAddr# #-}+writeWord8ArrayAsAddr# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+writeWord8ArrayAsAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsAddr# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsFloat# #-}+writeWord8ArrayAsFloat# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+writeWord8ArrayAsFloat# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsFloat# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsDouble# #-}+writeWord8ArrayAsDouble# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+writeWord8ArrayAsDouble# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsDouble# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsStablePtr# #-}+writeWord8ArrayAsStablePtr# :: MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+writeWord8ArrayAsStablePtr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsStablePtr# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsInt16# #-}+writeWord8ArrayAsInt16# :: MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+writeWord8ArrayAsInt16# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsInt16# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWord16# #-}+writeWord8ArrayAsWord16# :: MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+writeWord8ArrayAsWord16# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWord16# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsInt32# #-}+writeWord8ArrayAsInt32# :: MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+writeWord8ArrayAsInt32# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsInt32# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWord32# #-}+writeWord8ArrayAsWord32# :: MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+writeWord8ArrayAsWord32# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWord32# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsInt64# #-}+writeWord8ArrayAsInt64# :: MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+writeWord8ArrayAsInt64# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsInt64# a1 a2 a3 a4+{-# NOINLINE writeWord8ArrayAsWord64# #-}+writeWord8ArrayAsWord64# :: MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+writeWord8ArrayAsWord64# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8ArrayAsWord64# a1 a2 a3 a4+{-# NOINLINE compareByteArrays# #-}+compareByteArrays# :: ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#+compareByteArrays# a1 a2 a3 a4 a5 = GHC.Internal.Prim.compareByteArrays# a1 a2 a3 a4 a5+{-# NOINLINE copyByteArray# #-}+copyByteArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyByteArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyByteArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE copyMutableByteArray# #-}+copyMutableByteArray# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyMutableByteArray# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyMutableByteArray# a1 a2 a3 a4 a5 a6+{-# NOINLINE copyMutableByteArrayNonOverlapping# #-}+copyMutableByteArrayNonOverlapping# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyMutableByteArrayNonOverlapping# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.copyMutableByteArrayNonOverlapping# a1 a2 a3 a4 a5 a6+{-# NOINLINE copyByteArrayToAddr# #-}+copyByteArrayToAddr# :: ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s+copyByteArrayToAddr# a1 a2 a3 a4 a5 = GHC.Internal.Prim.copyByteArrayToAddr# a1 a2 a3 a4 a5+{-# NOINLINE copyMutableByteArrayToAddr# #-}+copyMutableByteArrayToAddr# :: MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s+copyMutableByteArrayToAddr# a1 a2 a3 a4 a5 = GHC.Internal.Prim.copyMutableByteArrayToAddr# a1 a2 a3 a4 a5+{-# NOINLINE copyAddrToByteArray# #-}+copyAddrToByteArray# :: Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+copyAddrToByteArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.copyAddrToByteArray# a1 a2 a3 a4 a5+{-# NOINLINE copyAddrToAddr# #-}+copyAddrToAddr# :: Addr# -> Addr# -> Int# -> State# (RealWorld) -> State# (RealWorld)+copyAddrToAddr# a1 a2 a3 a4 = GHC.Internal.Prim.copyAddrToAddr# a1 a2 a3 a4+{-# NOINLINE copyAddrToAddrNonOverlapping# #-}+copyAddrToAddrNonOverlapping# :: Addr# -> Addr# -> Int# -> State# (RealWorld) -> State# (RealWorld)+copyAddrToAddrNonOverlapping# a1 a2 a3 a4 = GHC.Internal.Prim.copyAddrToAddrNonOverlapping# a1 a2 a3 a4+{-# NOINLINE setByteArray# #-}+setByteArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s+setByteArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.setByteArray# a1 a2 a3 a4 a5+{-# NOINLINE setAddrRange# #-}+setAddrRange# :: Addr# -> Int# -> Int# -> State# (RealWorld) -> State# (RealWorld)+setAddrRange# a1 a2 a3 a4 = GHC.Internal.Prim.setAddrRange# a1 a2 a3 a4+{-# NOINLINE atomicReadIntArray# #-}+atomicReadIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #)+atomicReadIntArray# a1 a2 a3 = GHC.Internal.Prim.atomicReadIntArray# a1 a2 a3+{-# NOINLINE atomicWriteIntArray# #-}+atomicWriteIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+atomicWriteIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.atomicWriteIntArray# a1 a2 a3 a4+{-# NOINLINE casIntArray# #-}+casIntArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s,Int# #)+casIntArray# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casIntArray# a1 a2 a3 a4 a5+{-# NOINLINE casInt8Array# #-}+casInt8Array# :: MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s,Int8# #)+casInt8Array# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casInt8Array# a1 a2 a3 a4 a5+{-# NOINLINE casInt16Array# #-}+casInt16Array# :: MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s,Int16# #)+casInt16Array# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casInt16Array# a1 a2 a3 a4 a5+{-# NOINLINE casInt32Array# #-}+casInt32Array# :: MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s,Int32# #)+casInt32Array# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casInt32Array# a1 a2 a3 a4 a5+{-# NOINLINE casInt64Array# #-}+casInt64Array# :: MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s,Int64# #)+casInt64Array# a1 a2 a3 a4 a5 = GHC.Internal.Prim.casInt64Array# a1 a2 a3 a4 a5+{-# NOINLINE fetchAddIntArray# #-}+fetchAddIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchAddIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchAddIntArray# a1 a2 a3 a4+{-# NOINLINE fetchSubIntArray# #-}+fetchSubIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchSubIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchSubIntArray# a1 a2 a3 a4+{-# NOINLINE fetchAndIntArray# #-}+fetchAndIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchAndIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchAndIntArray# a1 a2 a3 a4+{-# NOINLINE fetchNandIntArray# #-}+fetchNandIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchNandIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchNandIntArray# a1 a2 a3 a4+{-# NOINLINE fetchOrIntArray# #-}+fetchOrIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchOrIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchOrIntArray# a1 a2 a3 a4+{-# NOINLINE fetchXorIntArray# #-}+fetchXorIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s,Int# #)+fetchXorIntArray# a1 a2 a3 a4 = GHC.Internal.Prim.fetchXorIntArray# a1 a2 a3 a4+{-# NOINLINE plusAddr# #-}+plusAddr# :: Addr# -> Int# -> Addr#+plusAddr# a1 a2 = GHC.Internal.Prim.plusAddr# a1 a2+{-# NOINLINE minusAddr# #-}+minusAddr# :: Addr# -> Addr# -> Int#+minusAddr# a1 a2 = GHC.Internal.Prim.minusAddr# a1 a2+{-# NOINLINE remAddr# #-}+remAddr# :: Addr# -> Int# -> Int#+remAddr# a1 a2 = GHC.Internal.Prim.remAddr# a1 a2+{-# NOINLINE addr2Int# #-}+addr2Int# :: Addr# -> Int#+addr2Int# a1 = GHC.Internal.Prim.addr2Int# a1+{-# NOINLINE int2Addr# #-}+int2Addr# :: Int# -> Addr#+int2Addr# a1 = GHC.Internal.Prim.int2Addr# a1+{-# NOINLINE gtAddr# #-}+gtAddr# :: Addr# -> Addr# -> Int#+gtAddr# a1 a2 = GHC.Internal.Prim.gtAddr# a1 a2+{-# NOINLINE geAddr# #-}+geAddr# :: Addr# -> Addr# -> Int#+geAddr# a1 a2 = GHC.Internal.Prim.geAddr# a1 a2+{-# NOINLINE eqAddr# #-}+eqAddr# :: Addr# -> Addr# -> Int#+eqAddr# a1 a2 = GHC.Internal.Prim.eqAddr# a1 a2+{-# NOINLINE neAddr# #-}+neAddr# :: Addr# -> Addr# -> Int#+neAddr# a1 a2 = GHC.Internal.Prim.neAddr# a1 a2+{-# NOINLINE ltAddr# #-}+ltAddr# :: Addr# -> Addr# -> Int#+ltAddr# a1 a2 = GHC.Internal.Prim.ltAddr# a1 a2+{-# NOINLINE leAddr# #-}+leAddr# :: Addr# -> Addr# -> Int#+leAddr# a1 a2 = GHC.Internal.Prim.leAddr# a1 a2+{-# NOINLINE indexCharOffAddr# #-}+indexCharOffAddr# :: Addr# -> Int# -> Char#+indexCharOffAddr# a1 a2 = GHC.Internal.Prim.indexCharOffAddr# a1 a2+{-# NOINLINE indexWideCharOffAddr# #-}+indexWideCharOffAddr# :: Addr# -> Int# -> Char#+indexWideCharOffAddr# a1 a2 = GHC.Internal.Prim.indexWideCharOffAddr# a1 a2+{-# NOINLINE indexIntOffAddr# #-}+indexIntOffAddr# :: Addr# -> Int# -> Int#+indexIntOffAddr# a1 a2 = GHC.Internal.Prim.indexIntOffAddr# a1 a2+{-# NOINLINE indexWordOffAddr# #-}+indexWordOffAddr# :: Addr# -> Int# -> Word#+indexWordOffAddr# a1 a2 = GHC.Internal.Prim.indexWordOffAddr# a1 a2+{-# NOINLINE indexAddrOffAddr# #-}+indexAddrOffAddr# :: Addr# -> Int# -> Addr#+indexAddrOffAddr# a1 a2 = GHC.Internal.Prim.indexAddrOffAddr# a1 a2+{-# NOINLINE indexFloatOffAddr# #-}+indexFloatOffAddr# :: Addr# -> Int# -> Float#+indexFloatOffAddr# a1 a2 = GHC.Internal.Prim.indexFloatOffAddr# a1 a2+{-# NOINLINE indexDoubleOffAddr# #-}+indexDoubleOffAddr# :: Addr# -> Int# -> Double#+indexDoubleOffAddr# a1 a2 = GHC.Internal.Prim.indexDoubleOffAddr# a1 a2+{-# NOINLINE indexStablePtrOffAddr# #-}+indexStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a+indexStablePtrOffAddr# a1 a2 = GHC.Internal.Prim.indexStablePtrOffAddr# a1 a2+{-# NOINLINE indexInt8OffAddr# #-}+indexInt8OffAddr# :: Addr# -> Int# -> Int8#+indexInt8OffAddr# a1 a2 = GHC.Internal.Prim.indexInt8OffAddr# a1 a2+{-# NOINLINE indexWord8OffAddr# #-}+indexWord8OffAddr# :: Addr# -> Int# -> Word8#+indexWord8OffAddr# a1 a2 = GHC.Internal.Prim.indexWord8OffAddr# a1 a2+{-# NOINLINE indexInt16OffAddr# #-}+indexInt16OffAddr# :: Addr# -> Int# -> Int16#+indexInt16OffAddr# a1 a2 = GHC.Internal.Prim.indexInt16OffAddr# a1 a2+{-# NOINLINE indexWord16OffAddr# #-}+indexWord16OffAddr# :: Addr# -> Int# -> Word16#+indexWord16OffAddr# a1 a2 = GHC.Internal.Prim.indexWord16OffAddr# a1 a2+{-# NOINLINE indexInt32OffAddr# #-}+indexInt32OffAddr# :: Addr# -> Int# -> Int32#+indexInt32OffAddr# a1 a2 = GHC.Internal.Prim.indexInt32OffAddr# a1 a2+{-# NOINLINE indexWord32OffAddr# #-}+indexWord32OffAddr# :: Addr# -> Int# -> Word32#+indexWord32OffAddr# a1 a2 = GHC.Internal.Prim.indexWord32OffAddr# a1 a2+{-# NOINLINE indexInt64OffAddr# #-}+indexInt64OffAddr# :: Addr# -> Int# -> Int64#+indexInt64OffAddr# a1 a2 = GHC.Internal.Prim.indexInt64OffAddr# a1 a2+{-# NOINLINE indexWord64OffAddr# #-}+indexWord64OffAddr# :: Addr# -> Int# -> Word64#+indexWord64OffAddr# a1 a2 = GHC.Internal.Prim.indexWord64OffAddr# a1 a2+{-# NOINLINE indexWord8OffAddrAsChar# #-}+indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char#+indexWord8OffAddrAsChar# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsChar# a1 a2+{-# NOINLINE indexWord8OffAddrAsWideChar# #-}+indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char#+indexWord8OffAddrAsWideChar# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWideChar# a1 a2+{-# NOINLINE indexWord8OffAddrAsInt# #-}+indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int#+indexWord8OffAddrAsInt# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsInt# a1 a2+{-# NOINLINE indexWord8OffAddrAsWord# #-}+indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word#+indexWord8OffAddrAsWord# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWord# a1 a2+{-# NOINLINE indexWord8OffAddrAsAddr# #-}+indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr#+indexWord8OffAddrAsAddr# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsAddr# a1 a2+{-# NOINLINE indexWord8OffAddrAsFloat# #-}+indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float#+indexWord8OffAddrAsFloat# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsFloat# a1 a2+{-# NOINLINE indexWord8OffAddrAsDouble# #-}+indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double#+indexWord8OffAddrAsDouble# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsDouble# a1 a2+{-# NOINLINE indexWord8OffAddrAsStablePtr# #-}+indexWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# a+indexWord8OffAddrAsStablePtr# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsStablePtr# a1 a2+{-# NOINLINE indexWord8OffAddrAsInt16# #-}+indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16#+indexWord8OffAddrAsInt16# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsInt16# a1 a2+{-# NOINLINE indexWord8OffAddrAsWord16# #-}+indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16#+indexWord8OffAddrAsWord16# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWord16# a1 a2+{-# NOINLINE indexWord8OffAddrAsInt32# #-}+indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32#+indexWord8OffAddrAsInt32# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsInt32# a1 a2+{-# NOINLINE indexWord8OffAddrAsWord32# #-}+indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32#+indexWord8OffAddrAsWord32# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWord32# a1 a2+{-# NOINLINE indexWord8OffAddrAsInt64# #-}+indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64#+indexWord8OffAddrAsInt64# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsInt64# a1 a2+{-# NOINLINE indexWord8OffAddrAsWord64# #-}+indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64#+indexWord8OffAddrAsWord64# a1 a2 = GHC.Internal.Prim.indexWord8OffAddrAsWord64# a1 a2+{-# NOINLINE readCharOffAddr# #-}+readCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readCharOffAddr# a1 a2 a3 = GHC.Internal.Prim.readCharOffAddr# a1 a2 a3+{-# NOINLINE readWideCharOffAddr# #-}+readWideCharOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWideCharOffAddr# a1 a2 a3 = GHC.Internal.Prim.readWideCharOffAddr# a1 a2 a3+{-# NOINLINE readIntOffAddr# #-}+readIntOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readIntOffAddr# a1 a2 a3 = GHC.Internal.Prim.readIntOffAddr# a1 a2 a3+{-# NOINLINE readWordOffAddr# #-}+readWordOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWordOffAddr# a1 a2 a3 = GHC.Internal.Prim.readWordOffAddr# a1 a2 a3+{-# NOINLINE readAddrOffAddr# #-}+readAddrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readAddrOffAddr# a1 a2 a3 = GHC.Internal.Prim.readAddrOffAddr# a1 a2 a3+{-# NOINLINE readFloatOffAddr# #-}+readFloatOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readFloatOffAddr# a1 a2 a3 = GHC.Internal.Prim.readFloatOffAddr# a1 a2 a3+{-# NOINLINE readDoubleOffAddr# #-}+readDoubleOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readDoubleOffAddr# a1 a2 a3 = GHC.Internal.Prim.readDoubleOffAddr# a1 a2 a3+{-# NOINLINE readStablePtrOffAddr# #-}+readStablePtrOffAddr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readStablePtrOffAddr# a1 a2 a3 = GHC.Internal.Prim.readStablePtrOffAddr# a1 a2 a3+{-# NOINLINE readInt8OffAddr# #-}+readInt8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int8# #)+readInt8OffAddr# a1 a2 a3 = GHC.Internal.Prim.readInt8OffAddr# a1 a2 a3+{-# NOINLINE readWord8OffAddr# #-}+readWord8OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word8# #)+readWord8OffAddr# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddr# a1 a2 a3+{-# NOINLINE readInt16OffAddr# #-}+readInt16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int16# #)+readInt16OffAddr# a1 a2 a3 = GHC.Internal.Prim.readInt16OffAddr# a1 a2 a3+{-# NOINLINE readWord16OffAddr# #-}+readWord16OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word16# #)+readWord16OffAddr# a1 a2 a3 = GHC.Internal.Prim.readWord16OffAddr# a1 a2 a3+{-# NOINLINE readInt32OffAddr# #-}+readInt32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int32# #)+readInt32OffAddr# a1 a2 a3 = GHC.Internal.Prim.readInt32OffAddr# a1 a2 a3+{-# NOINLINE readWord32OffAddr# #-}+readWord32OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word32# #)+readWord32OffAddr# a1 a2 a3 = GHC.Internal.Prim.readWord32OffAddr# a1 a2 a3+{-# NOINLINE readInt64OffAddr# #-}+readInt64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Int64# #)+readInt64OffAddr# a1 a2 a3 = GHC.Internal.Prim.readInt64OffAddr# a1 a2 a3+{-# NOINLINE readWord64OffAddr# #-}+readWord64OffAddr# :: Addr# -> Int# -> State# s -> (# State# s,Word64# #)+readWord64OffAddr# a1 a2 a3 = GHC.Internal.Prim.readWord64OffAddr# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsChar# #-}+readWord8OffAddrAsChar# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWord8OffAddrAsChar# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsChar# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWideChar# #-}+readWord8OffAddrAsWideChar# :: Addr# -> Int# -> State# s -> (# State# s,Char# #)+readWord8OffAddrAsWideChar# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWideChar# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsInt# #-}+readWord8OffAddrAsInt# :: Addr# -> Int# -> State# s -> (# State# s,Int# #)+readWord8OffAddrAsInt# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsInt# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWord# #-}+readWord8OffAddrAsWord# :: Addr# -> Int# -> State# s -> (# State# s,Word# #)+readWord8OffAddrAsWord# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWord# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsAddr# #-}+readWord8OffAddrAsAddr# :: Addr# -> Int# -> State# s -> (# State# s,Addr# #)+readWord8OffAddrAsAddr# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsAddr# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsFloat# #-}+readWord8OffAddrAsFloat# :: Addr# -> Int# -> State# s -> (# State# s,Float# #)+readWord8OffAddrAsFloat# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsFloat# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsDouble# #-}+readWord8OffAddrAsDouble# :: Addr# -> Int# -> State# s -> (# State# s,Double# #)+readWord8OffAddrAsDouble# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsDouble# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsStablePtr# #-}+readWord8OffAddrAsStablePtr# :: Addr# -> Int# -> State# s -> (# State# s,StablePtr# a #)+readWord8OffAddrAsStablePtr# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsStablePtr# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsInt16# #-}+readWord8OffAddrAsInt16# :: Addr# -> Int# -> State# s -> (# State# s,Int16# #)+readWord8OffAddrAsInt16# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsInt16# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWord16# #-}+readWord8OffAddrAsWord16# :: Addr# -> Int# -> State# s -> (# State# s,Word16# #)+readWord8OffAddrAsWord16# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWord16# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsInt32# #-}+readWord8OffAddrAsInt32# :: Addr# -> Int# -> State# s -> (# State# s,Int32# #)+readWord8OffAddrAsInt32# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsInt32# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWord32# #-}+readWord8OffAddrAsWord32# :: Addr# -> Int# -> State# s -> (# State# s,Word32# #)+readWord8OffAddrAsWord32# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWord32# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsInt64# #-}+readWord8OffAddrAsInt64# :: Addr# -> Int# -> State# s -> (# State# s,Int64# #)+readWord8OffAddrAsInt64# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsInt64# a1 a2 a3+{-# NOINLINE readWord8OffAddrAsWord64# #-}+readWord8OffAddrAsWord64# :: Addr# -> Int# -> State# s -> (# State# s,Word64# #)+readWord8OffAddrAsWord64# a1 a2 a3 = GHC.Internal.Prim.readWord8OffAddrAsWord64# a1 a2 a3+{-# NOINLINE writeCharOffAddr# #-}+writeCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeCharOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeCharOffAddr# a1 a2 a3 a4+{-# NOINLINE writeWideCharOffAddr# #-}+writeWideCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWideCharOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWideCharOffAddr# a1 a2 a3 a4+{-# NOINLINE writeIntOffAddr# #-}+writeIntOffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeIntOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeIntOffAddr# a1 a2 a3 a4+{-# NOINLINE writeWordOffAddr# #-}+writeWordOffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWordOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWordOffAddr# a1 a2 a3 a4+{-# NOINLINE writeAddrOffAddr# #-}+writeAddrOffAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeAddrOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeAddrOffAddr# a1 a2 a3 a4+{-# NOINLINE writeFloatOffAddr# #-}+writeFloatOffAddr# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeFloatOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeFloatOffAddr# a1 a2 a3 a4+{-# NOINLINE writeDoubleOffAddr# #-}+writeDoubleOffAddr# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeDoubleOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeDoubleOffAddr# a1 a2 a3 a4+{-# NOINLINE writeStablePtrOffAddr# #-}+writeStablePtrOffAddr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeStablePtrOffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeStablePtrOffAddr# a1 a2 a3 a4+{-# NOINLINE writeInt8OffAddr# #-}+writeInt8OffAddr# :: Addr# -> Int# -> Int8# -> State# s -> State# s+writeInt8OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt8OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddr# #-}+writeWord8OffAddr# :: Addr# -> Int# -> Word8# -> State# s -> State# s+writeWord8OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddr# a1 a2 a3 a4+{-# NOINLINE writeInt16OffAddr# #-}+writeInt16OffAddr# :: Addr# -> Int# -> Int16# -> State# s -> State# s+writeInt16OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt16OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord16OffAddr# #-}+writeWord16OffAddr# :: Addr# -> Int# -> Word16# -> State# s -> State# s+writeWord16OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord16OffAddr# a1 a2 a3 a4+{-# NOINLINE writeInt32OffAddr# #-}+writeInt32OffAddr# :: Addr# -> Int# -> Int32# -> State# s -> State# s+writeInt32OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt32OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord32OffAddr# #-}+writeWord32OffAddr# :: Addr# -> Int# -> Word32# -> State# s -> State# s+writeWord32OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord32OffAddr# a1 a2 a3 a4+{-# NOINLINE writeInt64OffAddr# #-}+writeInt64OffAddr# :: Addr# -> Int# -> Int64# -> State# s -> State# s+writeInt64OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeInt64OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord64OffAddr# #-}+writeWord64OffAddr# :: Addr# -> Int# -> Word64# -> State# s -> State# s+writeWord64OffAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord64OffAddr# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsChar# #-}+writeWord8OffAddrAsChar# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWord8OffAddrAsChar# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsChar# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWideChar# #-}+writeWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWord8OffAddrAsWideChar# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWideChar# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsInt# #-}+writeWord8OffAddrAsInt# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeWord8OffAddrAsInt# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsInt# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWord# #-}+writeWord8OffAddrAsWord# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord8OffAddrAsWord# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWord# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsAddr# #-}+writeWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeWord8OffAddrAsAddr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsAddr# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsFloat# #-}+writeWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# -> State# s -> State# s+writeWord8OffAddrAsFloat# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsFloat# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsDouble# #-}+writeWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# -> State# s -> State# s+writeWord8OffAddrAsDouble# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsDouble# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsStablePtr# #-}+writeWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# a -> State# s -> State# s+writeWord8OffAddrAsStablePtr# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsStablePtr# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsInt16# #-}+writeWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# -> State# s -> State# s+writeWord8OffAddrAsInt16# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsInt16# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWord16# #-}+writeWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# -> State# s -> State# s+writeWord8OffAddrAsWord16# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWord16# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsInt32# #-}+writeWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# -> State# s -> State# s+writeWord8OffAddrAsInt32# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsInt32# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWord32# #-}+writeWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# -> State# s -> State# s+writeWord8OffAddrAsWord32# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWord32# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsInt64# #-}+writeWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# -> State# s -> State# s+writeWord8OffAddrAsInt64# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsInt64# a1 a2 a3 a4+{-# NOINLINE writeWord8OffAddrAsWord64# #-}+writeWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# -> State# s -> State# s+writeWord8OffAddrAsWord64# a1 a2 a3 a4 = GHC.Internal.Prim.writeWord8OffAddrAsWord64# a1 a2 a3 a4+{-# NOINLINE atomicExchangeAddrAddr# #-}+atomicExchangeAddrAddr# :: Addr# -> Addr# -> State# s -> (# State# s,Addr# #)+atomicExchangeAddrAddr# a1 a2 a3 = GHC.Internal.Prim.atomicExchangeAddrAddr# a1 a2 a3+{-# NOINLINE atomicExchangeWordAddr# #-}+atomicExchangeWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+atomicExchangeWordAddr# a1 a2 a3 = GHC.Internal.Prim.atomicExchangeWordAddr# a1 a2 a3+{-# NOINLINE atomicCasAddrAddr# #-}+atomicCasAddrAddr# :: Addr# -> Addr# -> Addr# -> State# s -> (# State# s,Addr# #)+atomicCasAddrAddr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasAddrAddr# a1 a2 a3 a4+{-# NOINLINE atomicCasWordAddr# #-}+atomicCasWordAddr# :: Addr# -> Word# -> Word# -> State# s -> (# State# s,Word# #)+atomicCasWordAddr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWordAddr# a1 a2 a3 a4+{-# NOINLINE atomicCasWord8Addr# #-}+atomicCasWord8Addr# :: Addr# -> Word8# -> Word8# -> State# s -> (# State# s,Word8# #)+atomicCasWord8Addr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWord8Addr# a1 a2 a3 a4+{-# NOINLINE atomicCasWord16Addr# #-}+atomicCasWord16Addr# :: Addr# -> Word16# -> Word16# -> State# s -> (# State# s,Word16# #)+atomicCasWord16Addr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWord16Addr# a1 a2 a3 a4+{-# NOINLINE atomicCasWord32Addr# #-}+atomicCasWord32Addr# :: Addr# -> Word32# -> Word32# -> State# s -> (# State# s,Word32# #)+atomicCasWord32Addr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWord32Addr# a1 a2 a3 a4+{-# NOINLINE atomicCasWord64Addr# #-}+atomicCasWord64Addr# :: Addr# -> Word64# -> Word64# -> State# s -> (# State# s,Word64# #)+atomicCasWord64Addr# a1 a2 a3 a4 = GHC.Internal.Prim.atomicCasWord64Addr# a1 a2 a3 a4+{-# NOINLINE fetchAddWordAddr# #-}+fetchAddWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchAddWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchAddWordAddr# a1 a2 a3+{-# NOINLINE fetchSubWordAddr# #-}+fetchSubWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchSubWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchSubWordAddr# a1 a2 a3+{-# NOINLINE fetchAndWordAddr# #-}+fetchAndWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchAndWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchAndWordAddr# a1 a2 a3+{-# NOINLINE fetchNandWordAddr# #-}+fetchNandWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchNandWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchNandWordAddr# a1 a2 a3+{-# NOINLINE fetchOrWordAddr# #-}+fetchOrWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchOrWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchOrWordAddr# a1 a2 a3+{-# NOINLINE fetchXorWordAddr# #-}+fetchXorWordAddr# :: Addr# -> Word# -> State# s -> (# State# s,Word# #)+fetchXorWordAddr# a1 a2 a3 = GHC.Internal.Prim.fetchXorWordAddr# a1 a2 a3+{-# NOINLINE atomicReadWordAddr# #-}+atomicReadWordAddr# :: Addr# -> State# s -> (# State# s,Word# #)+atomicReadWordAddr# a1 a2 = GHC.Internal.Prim.atomicReadWordAddr# a1 a2+{-# NOINLINE atomicWriteWordAddr# #-}+atomicWriteWordAddr# :: Addr# -> Word# -> State# s -> State# s+atomicWriteWordAddr# a1 a2 a3 = GHC.Internal.Prim.atomicWriteWordAddr# a1 a2 a3+{-# NOINLINE newMutVar# #-}+newMutVar# :: a_levpoly -> State# s -> (# State# s,MutVar# s a_levpoly #)+newMutVar# a1 a2 = GHC.Internal.Prim.newMutVar# a1 a2+{-# NOINLINE readMutVar# #-}+readMutVar# :: MutVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readMutVar# a1 a2 = GHC.Internal.Prim.readMutVar# a1 a2+{-# NOINLINE writeMutVar# #-}+writeMutVar# :: MutVar# s a_levpoly -> a_levpoly -> State# s -> State# s+writeMutVar# a1 a2 a3 = GHC.Internal.Prim.writeMutVar# a1 a2 a3+{-# NOINLINE atomicSwapMutVar# #-}+atomicSwapMutVar# :: MutVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s,a_levpoly #)+atomicSwapMutVar# a1 a2 a3 = GHC.Internal.Prim.atomicSwapMutVar# a1 a2 a3+{-# NOINLINE atomicModifyMutVar2# #-}+atomicModifyMutVar2# :: MutVar# s a -> (a -> c) -> State# s -> (# State# s,a,c #)+atomicModifyMutVar2# a1 a2 a3 = GHC.Internal.Prim.atomicModifyMutVar2# a1 a2 a3+{-# NOINLINE atomicModifyMutVar_# #-}+atomicModifyMutVar_# :: MutVar# s a -> (a -> a) -> State# s -> (# State# s,a,a #)+atomicModifyMutVar_# a1 a2 a3 = GHC.Internal.Prim.atomicModifyMutVar_# a1 a2 a3+{-# NOINLINE casMutVar# #-}+casMutVar# :: MutVar# s a_levpoly -> a_levpoly -> a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+casMutVar# a1 a2 a3 a4 = GHC.Internal.Prim.casMutVar# a1 a2 a3 a4+{-# NOINLINE catch# #-}+catch# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> (b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+catch# a1 a2 a3 = GHC.Internal.Prim.catch# a1 a2 a3+{-# NOINLINE raise# #-}+raise# :: a_levpoly -> b_reppoly+raise# a1 = GHC.Internal.Prim.raise# a1+{-# NOINLINE raiseUnderflow# #-}+raiseUnderflow# :: (#  #) -> b_reppoly+raiseUnderflow# a1 = GHC.Internal.Prim.raiseUnderflow# a1+{-# NOINLINE raiseOverflow# #-}+raiseOverflow# :: (#  #) -> b_reppoly+raiseOverflow# a1 = GHC.Internal.Prim.raiseOverflow# a1+{-# NOINLINE raiseDivZero# #-}+raiseDivZero# :: (#  #) -> b_reppoly+raiseDivZero# a1 = GHC.Internal.Prim.raiseDivZero# a1+{-# NOINLINE raiseIO# #-}+raiseIO# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)+raiseIO# a1 a2 = GHC.Internal.Prim.raiseIO# a1 a2+{-# NOINLINE maskAsyncExceptions# #-}+maskAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+maskAsyncExceptions# a1 a2 = GHC.Internal.Prim.maskAsyncExceptions# a1 a2+{-# NOINLINE maskUninterruptible# #-}+maskUninterruptible# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+maskUninterruptible# a1 a2 = GHC.Internal.Prim.maskUninterruptible# a1 a2+{-# NOINLINE unmaskAsyncExceptions# #-}+unmaskAsyncExceptions# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)+unmaskAsyncExceptions# a1 a2 = GHC.Internal.Prim.unmaskAsyncExceptions# a1 a2+{-# NOINLINE getMaskingState# #-}+getMaskingState# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+getMaskingState# a1 = GHC.Internal.Prim.getMaskingState# a1+{-# NOINLINE newPromptTag# #-}+newPromptTag# :: State# (RealWorld) -> (# State# (RealWorld),PromptTag# a #)+newPromptTag# a1 = GHC.Internal.Prim.newPromptTag# a1+{-# NOINLINE prompt# #-}+prompt# :: PromptTag# a -> (State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)+prompt# a1 a2 a3 = GHC.Internal.Prim.prompt# a1 a2 a3+{-# NOINLINE control0# #-}+control0# :: PromptTag# a -> (((State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),a #)) -> State# (RealWorld) -> (# State# (RealWorld),b_reppoly #)+control0# a1 a2 a3 = GHC.Internal.Prim.control0# a1 a2 a3+{-# NOINLINE atomically# #-}+atomically# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+atomically# a1 a2 = GHC.Internal.Prim.atomically# a1 a2+{-# NOINLINE retry# #-}+retry# :: State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+retry# a1 = GHC.Internal.Prim.retry# a1+{-# NOINLINE catchRetry# #-}+catchRetry# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+catchRetry# a1 a2 a3 = GHC.Internal.Prim.catchRetry# a1 a2 a3+{-# NOINLINE catchSTM# #-}+catchSTM# :: (State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> (b -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)) -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+catchSTM# a1 a2 a3 = GHC.Internal.Prim.catchSTM# a1 a2 a3+{-# NOINLINE newTVar# #-}+newTVar# :: a_levpoly -> State# s -> (# State# s,TVar# s a_levpoly #)+newTVar# a1 a2 = GHC.Internal.Prim.newTVar# a1 a2+{-# NOINLINE readTVar# #-}+readTVar# :: TVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readTVar# a1 a2 = GHC.Internal.Prim.readTVar# a1 a2+{-# NOINLINE readTVarIO# #-}+readTVarIO# :: TVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readTVarIO# a1 a2 = GHC.Internal.Prim.readTVarIO# a1 a2+{-# NOINLINE writeTVar# #-}+writeTVar# :: TVar# s a_levpoly -> a_levpoly -> State# s -> State# s+writeTVar# a1 a2 a3 = GHC.Internal.Prim.writeTVar# a1 a2 a3+{-# NOINLINE newMVar# #-}+newMVar# :: State# s -> (# State# s,MVar# s a_levpoly #)+newMVar# a1 = GHC.Internal.Prim.newMVar# a1+{-# NOINLINE takeMVar# #-}+takeMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+takeMVar# a1 a2 = GHC.Internal.Prim.takeMVar# a1 a2+{-# NOINLINE tryTakeMVar# #-}+tryTakeMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+tryTakeMVar# a1 a2 = GHC.Internal.Prim.tryTakeMVar# a1 a2+{-# NOINLINE putMVar# #-}+putMVar# :: MVar# s a_levpoly -> a_levpoly -> State# s -> State# s+putMVar# a1 a2 a3 = GHC.Internal.Prim.putMVar# a1 a2 a3+{-# NOINLINE tryPutMVar# #-}+tryPutMVar# :: MVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s,Int# #)+tryPutMVar# a1 a2 a3 = GHC.Internal.Prim.tryPutMVar# a1 a2 a3+{-# NOINLINE readMVar# #-}+readMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,a_levpoly #)+readMVar# a1 a2 = GHC.Internal.Prim.readMVar# a1 a2+{-# NOINLINE tryReadMVar# #-}+tryReadMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int#,a_levpoly #)+tryReadMVar# a1 a2 = GHC.Internal.Prim.tryReadMVar# a1 a2+{-# NOINLINE isEmptyMVar# #-}+isEmptyMVar# :: MVar# s a_levpoly -> State# s -> (# State# s,Int# #)+isEmptyMVar# a1 a2 = GHC.Internal.Prim.isEmptyMVar# a1 a2+{-# NOINLINE delay# #-}+delay# :: Int# -> State# s -> State# s+delay# a1 a2 = GHC.Internal.Prim.delay# a1 a2+{-# NOINLINE waitRead# #-}+waitRead# :: Int# -> State# s -> State# s+waitRead# a1 a2 = GHC.Internal.Prim.waitRead# a1 a2+{-# NOINLINE waitWrite# #-}+waitWrite# :: Int# -> State# s -> State# s+waitWrite# a1 a2 = GHC.Internal.Prim.waitWrite# a1 a2+{-# NOINLINE fork# #-}+fork# :: (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+fork# a1 a2 = GHC.Internal.Prim.fork# a1 a2+{-# NOINLINE forkOn# #-}+forkOn# :: Int# -> (State# (RealWorld) -> (# State# (RealWorld),a_reppoly #)) -> State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+forkOn# a1 a2 a3 = GHC.Internal.Prim.forkOn# a1 a2 a3+{-# NOINLINE killThread# #-}+killThread# :: ThreadId# -> a -> State# (RealWorld) -> State# (RealWorld)+killThread# a1 a2 a3 = GHC.Internal.Prim.killThread# a1 a2 a3+{-# NOINLINE yield# #-}+yield# :: State# (RealWorld) -> State# (RealWorld)+yield# a1 = GHC.Internal.Prim.yield# a1+{-# NOINLINE myThreadId# #-}+myThreadId# :: State# (RealWorld) -> (# State# (RealWorld),ThreadId# #)+myThreadId# a1 = GHC.Internal.Prim.myThreadId# a1+{-# NOINLINE labelThread# #-}+labelThread# :: ThreadId# -> ByteArray# -> State# (RealWorld) -> State# (RealWorld)+labelThread# a1 a2 a3 = GHC.Internal.Prim.labelThread# a1 a2 a3+{-# NOINLINE isCurrentThreadBound# #-}+isCurrentThreadBound# :: State# (RealWorld) -> (# State# (RealWorld),Int# #)+isCurrentThreadBound# a1 = GHC.Internal.Prim.isCurrentThreadBound# a1+{-# NOINLINE noDuplicate# #-}+noDuplicate# :: State# s -> State# s+noDuplicate# a1 = GHC.Internal.Prim.noDuplicate# a1+{-# NOINLINE threadLabel# #-}+threadLabel# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int#,ByteArray# #)+threadLabel# a1 a2 = GHC.Internal.Prim.threadLabel# a1 a2+{-# NOINLINE threadStatus# #-}+threadStatus# :: ThreadId# -> State# (RealWorld) -> (# State# (RealWorld),Int#,Int#,Int# #)+threadStatus# a1 a2 = GHC.Internal.Prim.threadStatus# a1 a2+{-# NOINLINE listThreads# #-}+listThreads# :: State# (RealWorld) -> (# State# (RealWorld),Array# (ThreadId#) #)+listThreads# a1 = GHC.Internal.Prim.listThreads# a1+{-# NOINLINE mkWeak# #-}+mkWeak# :: a_levpoly -> b_levpoly -> (State# (RealWorld) -> (# State# (RealWorld),c #)) -> State# (RealWorld) -> (# State# (RealWorld),Weak# b_levpoly #)+mkWeak# a1 a2 a3 a4 = GHC.Internal.Prim.mkWeak# a1 a2 a3 a4+{-# NOINLINE mkWeakNoFinalizer# #-}+mkWeakNoFinalizer# :: a_levpoly -> b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Weak# b_levpoly #)+mkWeakNoFinalizer# a1 a2 a3 = GHC.Internal.Prim.mkWeakNoFinalizer# a1 a2 a3+{-# NOINLINE addCFinalizerToWeak# #-}+addCFinalizerToWeak# :: Addr# -> Addr# -> Int# -> Addr# -> Weak# b_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+addCFinalizerToWeak# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.addCFinalizerToWeak# a1 a2 a3 a4 a5 a6+{-# NOINLINE deRefWeak# #-}+deRefWeak# :: Weak# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int#,a_levpoly #)+deRefWeak# a1 a2 = GHC.Internal.Prim.deRefWeak# a1 a2+{-# NOINLINE finalizeWeak# #-}+finalizeWeak# :: Weak# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),Int#,State# (RealWorld) -> (# State# (RealWorld),b #) #)+finalizeWeak# a1 a2 = GHC.Internal.Prim.finalizeWeak# a1 a2+{-# NOINLINE touch# #-}+touch# :: a_levpoly -> State# s -> State# s+touch# a1 a2 = GHC.Internal.Prim.touch# a1 a2+{-# NOINLINE makeStablePtr# #-}+makeStablePtr# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),StablePtr# a_levpoly #)+makeStablePtr# a1 a2 = GHC.Internal.Prim.makeStablePtr# a1 a2+{-# NOINLINE deRefStablePtr# #-}+deRefStablePtr# :: StablePtr# a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),a_levpoly #)+deRefStablePtr# a1 a2 = GHC.Internal.Prim.deRefStablePtr# a1 a2+{-# NOINLINE eqStablePtr# #-}+eqStablePtr# :: StablePtr# a_levpoly -> StablePtr# a_levpoly -> Int#+eqStablePtr# a1 a2 = GHC.Internal.Prim.eqStablePtr# a1 a2+{-# NOINLINE makeStableName# #-}+makeStableName# :: a_levpoly -> State# (RealWorld) -> (# State# (RealWorld),StableName# a_levpoly #)+makeStableName# a1 a2 = GHC.Internal.Prim.makeStableName# a1 a2+{-# NOINLINE stableNameToInt# #-}+stableNameToInt# :: StableName# a_levpoly -> Int#+stableNameToInt# a1 = GHC.Internal.Prim.stableNameToInt# a1+{-# NOINLINE compactNew# #-}+compactNew# :: Word# -> State# (RealWorld) -> (# State# (RealWorld),Compact# #)+compactNew# a1 a2 = GHC.Internal.Prim.compactNew# a1 a2+{-# NOINLINE compactResize# #-}+compactResize# :: Compact# -> Word# -> State# (RealWorld) -> State# (RealWorld)+compactResize# a1 a2 a3 = GHC.Internal.Prim.compactResize# a1 a2 a3+{-# NOINLINE compactContains# #-}+compactContains# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+compactContains# a1 a2 a3 = GHC.Internal.Prim.compactContains# a1 a2 a3+{-# NOINLINE compactContainsAny# #-}+compactContainsAny# :: a -> State# (RealWorld) -> (# State# (RealWorld),Int# #)+compactContainsAny# a1 a2 = GHC.Internal.Prim.compactContainsAny# a1 a2+{-# NOINLINE compactGetFirstBlock# #-}+compactGetFirstBlock# :: Compact# -> State# (RealWorld) -> (# State# (RealWorld),Addr#,Word# #)+compactGetFirstBlock# a1 a2 = GHC.Internal.Prim.compactGetFirstBlock# a1 a2+{-# NOINLINE compactGetNextBlock# #-}+compactGetNextBlock# :: Compact# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Addr#,Word# #)+compactGetNextBlock# a1 a2 a3 = GHC.Internal.Prim.compactGetNextBlock# a1 a2 a3+{-# NOINLINE compactAllocateBlock# #-}+compactAllocateBlock# :: Word# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Addr# #)+compactAllocateBlock# a1 a2 a3 = GHC.Internal.Prim.compactAllocateBlock# a1 a2 a3+{-# NOINLINE compactFixupPointers# #-}+compactFixupPointers# :: Addr# -> Addr# -> State# (RealWorld) -> (# State# (RealWorld),Compact#,Addr# #)+compactFixupPointers# a1 a2 a3 = GHC.Internal.Prim.compactFixupPointers# a1 a2 a3+{-# NOINLINE compactAdd# #-}+compactAdd# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),a #)+compactAdd# a1 a2 a3 = GHC.Internal.Prim.compactAdd# a1 a2 a3+{-# NOINLINE compactAddWithSharing# #-}+compactAddWithSharing# :: Compact# -> a -> State# (RealWorld) -> (# State# (RealWorld),a #)+compactAddWithSharing# a1 a2 a3 = GHC.Internal.Prim.compactAddWithSharing# a1 a2 a3+{-# NOINLINE compactSize# #-}+compactSize# :: Compact# -> State# (RealWorld) -> (# State# (RealWorld),Word# #)+compactSize# a1 a2 = GHC.Internal.Prim.compactSize# a1 a2+{-# NOINLINE reallyUnsafePtrEquality# #-}+reallyUnsafePtrEquality# :: a_levpoly -> b_levpoly -> Int#+reallyUnsafePtrEquality# a1 a2 = GHC.Internal.Prim.reallyUnsafePtrEquality# a1 a2+{-# NOINLINE par# #-}+par# :: a -> Int#+par# a1 = GHC.Internal.Prim.par# a1+{-# NOINLINE spark# #-}+spark# :: a -> State# s -> (# State# s,a #)+spark# a1 a2 = GHC.Internal.Prim.spark# a1 a2+{-# NOINLINE getSpark# #-}+getSpark# :: State# s -> (# State# s,Int#,a #)+getSpark# a1 = GHC.Internal.Prim.getSpark# a1+{-# NOINLINE numSparks# #-}+numSparks# :: State# s -> (# State# s,Int# #)+numSparks# a1 = GHC.Internal.Prim.numSparks# a1+{-# NOINLINE keepAlive# #-}+keepAlive# :: a_levpoly -> State# s -> (State# s -> b_reppoly) -> b_reppoly+keepAlive# a1 a2 a3 = GHC.Internal.Prim.keepAlive# a1 a2 a3+{-# NOINLINE dataToTagSmall# #-}+dataToTagSmall# :: a_levpoly -> Int#+dataToTagSmall# a1 = GHC.Internal.Prim.dataToTagSmall# a1+{-# NOINLINE dataToTagLarge# #-}+dataToTagLarge# :: a_levpoly -> Int#+dataToTagLarge# a1 = GHC.Internal.Prim.dataToTagLarge# a1+{-# NOINLINE addrToAny# #-}+addrToAny# :: Addr# -> (# a_levpoly #)+addrToAny# a1 = GHC.Internal.Prim.addrToAny# a1+{-# NOINLINE anyToAddr# #-}+anyToAddr# :: a -> State# (RealWorld) -> (# State# (RealWorld),Addr# #)+anyToAddr# a1 a2 = GHC.Internal.Prim.anyToAddr# a1 a2+{-# NOINLINE mkApUpd0# #-}+mkApUpd0# :: BCO -> (# a #)+mkApUpd0# a1 = GHC.Internal.Prim.mkApUpd0# a1+{-# NOINLINE newBCO# #-}+newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s,BCO #)+newBCO# a1 a2 a3 a4 a5 a6 = GHC.Internal.Prim.newBCO# a1 a2 a3 a4 a5 a6+{-# NOINLINE unpackClosure# #-}+unpackClosure# :: a -> (# Addr#,ByteArray#,Array# b #)+unpackClosure# a1 = GHC.Internal.Prim.unpackClosure# a1+{-# NOINLINE closureSize# #-}+closureSize# :: a -> Int#+closureSize# a1 = GHC.Internal.Prim.closureSize# a1+{-# NOINLINE getApStackVal# #-}+getApStackVal# :: a -> Int# -> (# Int#,b #)+getApStackVal# a1 a2 = GHC.Internal.Prim.getApStackVal# a1 a2+{-# NOINLINE getCCSOf# #-}+getCCSOf# :: a -> State# s -> (# State# s,Addr# #)+getCCSOf# a1 a2 = GHC.Internal.Prim.getCCSOf# a1 a2+{-# NOINLINE getCurrentCCS# #-}+getCurrentCCS# :: a -> State# s -> (# State# s,Addr# #)+getCurrentCCS# a1 a2 = GHC.Internal.Prim.getCurrentCCS# a1 a2+{-# NOINLINE clearCCS# #-}+clearCCS# :: (State# s -> (# State# s,a #)) -> State# s -> (# State# s,a #)+clearCCS# a1 a2 = GHC.Internal.Prim.clearCCS# a1 a2+{-# NOINLINE annotateStack# #-}+annotateStack# :: b -> (State# s -> (# State# s,a_reppoly #)) -> State# s -> (# State# s,a_reppoly #)+annotateStack# a1 a2 a3 = GHC.Internal.Prim.annotateStack# a1 a2 a3+{-# NOINLINE whereFrom# #-}+whereFrom# :: a -> Addr# -> State# s -> (# State# s,Int# #)+whereFrom# a1 a2 a3 = GHC.Internal.Prim.whereFrom# a1 a2 a3+{-# NOINLINE traceEvent# #-}+traceEvent# :: Addr# -> State# s -> State# s+traceEvent# a1 a2 = GHC.Internal.Prim.traceEvent# a1 a2+{-# NOINLINE traceBinaryEvent# #-}+traceBinaryEvent# :: Addr# -> Int# -> State# s -> State# s+traceBinaryEvent# a1 a2 a3 = GHC.Internal.Prim.traceBinaryEvent# a1 a2 a3+{-# NOINLINE traceMarker# #-}+traceMarker# :: Addr# -> State# s -> State# s+traceMarker# a1 a2 = GHC.Internal.Prim.traceMarker# a1 a2+{-# NOINLINE setThreadAllocationCounter# #-}+setThreadAllocationCounter# :: Int64# -> State# (RealWorld) -> State# (RealWorld)+setThreadAllocationCounter# a1 a2 = GHC.Internal.Prim.setThreadAllocationCounter# a1 a2+{-# NOINLINE setOtherThreadAllocationCounter# #-}+setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# (RealWorld) -> State# (RealWorld)+setOtherThreadAllocationCounter# a1 a2 a3 = GHC.Internal.Prim.setOtherThreadAllocationCounter# a1 a2 a3+{-# NOINLINE prefetchByteArray3# #-}+prefetchByteArray3# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray3# a1 a2 a3 = GHC.Internal.Prim.prefetchByteArray3# a1 a2 a3+{-# NOINLINE prefetchMutableByteArray3# #-}+prefetchMutableByteArray3# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray3# a1 a2 a3 = GHC.Internal.Prim.prefetchMutableByteArray3# a1 a2 a3+{-# NOINLINE prefetchAddr3# #-}+prefetchAddr3# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr3# a1 a2 a3 = GHC.Internal.Prim.prefetchAddr3# a1 a2 a3+{-# NOINLINE prefetchValue3# #-}+prefetchValue3# :: a -> State# s -> State# s+prefetchValue3# a1 a2 = GHC.Internal.Prim.prefetchValue3# a1 a2+{-# NOINLINE prefetchByteArray2# #-}+prefetchByteArray2# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray2# a1 a2 a3 = GHC.Internal.Prim.prefetchByteArray2# a1 a2 a3+{-# NOINLINE prefetchMutableByteArray2# #-}+prefetchMutableByteArray2# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray2# a1 a2 a3 = GHC.Internal.Prim.prefetchMutableByteArray2# a1 a2 a3+{-# NOINLINE prefetchAddr2# #-}+prefetchAddr2# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr2# a1 a2 a3 = GHC.Internal.Prim.prefetchAddr2# a1 a2 a3+{-# NOINLINE prefetchValue2# #-}+prefetchValue2# :: a -> State# s -> State# s+prefetchValue2# a1 a2 = GHC.Internal.Prim.prefetchValue2# a1 a2+{-# NOINLINE prefetchByteArray1# #-}+prefetchByteArray1# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray1# a1 a2 a3 = GHC.Internal.Prim.prefetchByteArray1# a1 a2 a3+{-# NOINLINE prefetchMutableByteArray1# #-}+prefetchMutableByteArray1# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray1# a1 a2 a3 = GHC.Internal.Prim.prefetchMutableByteArray1# a1 a2 a3+{-# NOINLINE prefetchAddr1# #-}+prefetchAddr1# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr1# a1 a2 a3 = GHC.Internal.Prim.prefetchAddr1# a1 a2 a3+{-# NOINLINE prefetchValue1# #-}+prefetchValue1# :: a -> State# s -> State# s+prefetchValue1# a1 a2 = GHC.Internal.Prim.prefetchValue1# a1 a2+{-# NOINLINE prefetchByteArray0# #-}+prefetchByteArray0# :: ByteArray# -> Int# -> State# s -> State# s+prefetchByteArray0# a1 a2 a3 = GHC.Internal.Prim.prefetchByteArray0# a1 a2 a3+{-# NOINLINE prefetchMutableByteArray0# #-}+prefetchMutableByteArray0# :: MutableByteArray# s -> Int# -> State# s -> State# s+prefetchMutableByteArray0# a1 a2 a3 = GHC.Internal.Prim.prefetchMutableByteArray0# a1 a2 a3+{-# NOINLINE prefetchAddr0# #-}+prefetchAddr0# :: Addr# -> Int# -> State# s -> State# s+prefetchAddr0# a1 a2 a3 = GHC.Internal.Prim.prefetchAddr0# a1 a2 a3+{-# NOINLINE prefetchValue0# #-}+prefetchValue0# :: a -> State# s -> State# s+prefetchValue0# a1 a2 = GHC.Internal.Prim.prefetchValue0# a1 a2
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -8,7 +8,7 @@ // WORD_SIZE 8 // BITMAP_BITS_SHIFT 6 // TAG_BITS 3-#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,8,16,0,8,8,0,8,0,112,128,16,8,16,0,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1"+#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,8,8,16,0,8,8,0,8,0,112,128,16,8,16,0,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1" #define CONTROL_GROUP_CONST_291 291 #define STD_HDR_SIZE 1 #define PROF_HDR_SIZE 2@@ -188,6 +188,11 @@ #define OFFSET_StgDeadThreadFrame_result 0 #define REP_StgDeadThreadFrame_result b64 #define StgDeadThreadFrame_result(__ptr__) REP_StgDeadThreadFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgDeadThreadFrame_result]+#define SIZEOF_StgAnnFrame_NoHdr 8+#define SIZEOF_StgAnnFrame (SIZEOF_StgHeader+8)+#define OFFSET_StgAnnFrame_ann 0+#define REP_StgAnnFrame_ann b64+#define StgAnnFrame_ann(__ptr__) REP_StgAnnFrame_ann[__ptr__+SIZEOF_StgHeader+OFFSET_StgAnnFrame_ann] #define SIZEOF_StgMutArrPtrs_NoHdr 16 #define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16) #define OFFSET_StgMutArrPtrs_ptrs 0@@ -536,19 +541,19 @@ #define OFFSET_StgCompactNFDataBlock_next 16 #define REP_StgCompactNFDataBlock_next b64 #define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 288+#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 296 #define REP_RtsFlags_ProfFlags_doHeapProfile b32 #define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile]-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 311+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 319 #define REP_RtsFlags_ProfFlags_showCCSOnException b8 #define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]-#define OFFSET_RtsFlags_DebugFlags_apply 253+#define OFFSET_RtsFlags_DebugFlags_apply 261 #define REP_RtsFlags_DebugFlags_apply b8 #define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 247+#define OFFSET_RtsFlags_DebugFlags_sanity 255 #define REP_RtsFlags_DebugFlags_sanity b8 #define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 242+#define OFFSET_RtsFlags_DebugFlags_weak 250 #define REP_RtsFlags_DebugFlags_weak b8 #define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak] #define OFFSET_RtsFlags_GcFlags_initialStkSize 16@@ -631,75 +636,75 @@ #define OFFSET_HsIface_heapOverflow_closure 72 #define REP_HsIface_heapOverflow_closure b64 #define HsIface_heapOverflow_closure(__ptr__) REP_HsIface_heapOverflow_closure[__ptr__+OFFSET_HsIface_heapOverflow_closure]-#define OFFSET_HsIface_doubleReadException_closure 80-#define REP_HsIface_doubleReadException_closure b64-#define HsIface_doubleReadException_closure(__ptr__) REP_HsIface_doubleReadException_closure[__ptr__+OFFSET_HsIface_doubleReadException_closure]-#define OFFSET_HsIface_allocationLimitExceeded_closure 88+#define OFFSET_HsIface_allocationLimitExceeded_closure 80 #define REP_HsIface_allocationLimitExceeded_closure b64 #define HsIface_allocationLimitExceeded_closure(__ptr__) REP_HsIface_allocationLimitExceeded_closure[__ptr__+OFFSET_HsIface_allocationLimitExceeded_closure]-#define OFFSET_HsIface_blockedIndefinitelyOnMVar_closure 96+#define OFFSET_HsIface_blockedIndefinitelyOnMVar_closure 88 #define REP_HsIface_blockedIndefinitelyOnMVar_closure b64 #define HsIface_blockedIndefinitelyOnMVar_closure(__ptr__) REP_HsIface_blockedIndefinitelyOnMVar_closure[__ptr__+OFFSET_HsIface_blockedIndefinitelyOnMVar_closure]-#define OFFSET_HsIface_blockedIndefinitelyOnSTM_closure 104+#define OFFSET_HsIface_blockedIndefinitelyOnSTM_closure 96 #define REP_HsIface_blockedIndefinitelyOnSTM_closure b64 #define HsIface_blockedIndefinitelyOnSTM_closure(__ptr__) REP_HsIface_blockedIndefinitelyOnSTM_closure[__ptr__+OFFSET_HsIface_blockedIndefinitelyOnSTM_closure]-#define OFFSET_HsIface_cannotCompactFunction_closure 112+#define OFFSET_HsIface_cannotCompactFunction_closure 104 #define REP_HsIface_cannotCompactFunction_closure b64 #define HsIface_cannotCompactFunction_closure(__ptr__) REP_HsIface_cannotCompactFunction_closure[__ptr__+OFFSET_HsIface_cannotCompactFunction_closure]-#define OFFSET_HsIface_cannotCompactPinned_closure 120+#define OFFSET_HsIface_cannotCompactPinned_closure 112 #define REP_HsIface_cannotCompactPinned_closure b64 #define HsIface_cannotCompactPinned_closure(__ptr__) REP_HsIface_cannotCompactPinned_closure[__ptr__+OFFSET_HsIface_cannotCompactPinned_closure]-#define OFFSET_HsIface_cannotCompactMutable_closure 128+#define OFFSET_HsIface_cannotCompactMutable_closure 120 #define REP_HsIface_cannotCompactMutable_closure b64 #define HsIface_cannotCompactMutable_closure(__ptr__) REP_HsIface_cannotCompactMutable_closure[__ptr__+OFFSET_HsIface_cannotCompactMutable_closure]-#define OFFSET_HsIface_nonTermination_closure 136+#define OFFSET_HsIface_nonTermination_closure 128 #define REP_HsIface_nonTermination_closure b64 #define HsIface_nonTermination_closure(__ptr__) REP_HsIface_nonTermination_closure[__ptr__+OFFSET_HsIface_nonTermination_closure]-#define OFFSET_HsIface_nestedAtomically_closure 144+#define OFFSET_HsIface_nestedAtomically_closure 136 #define REP_HsIface_nestedAtomically_closure b64 #define HsIface_nestedAtomically_closure(__ptr__) REP_HsIface_nestedAtomically_closure[__ptr__+OFFSET_HsIface_nestedAtomically_closure]-#define OFFSET_HsIface_noMatchingContinuationPrompt_closure 152+#define OFFSET_HsIface_noMatchingContinuationPrompt_closure 144 #define REP_HsIface_noMatchingContinuationPrompt_closure b64 #define HsIface_noMatchingContinuationPrompt_closure(__ptr__) REP_HsIface_noMatchingContinuationPrompt_closure[__ptr__+OFFSET_HsIface_noMatchingContinuationPrompt_closure]-#define OFFSET_HsIface_blockedOnBadFD_closure 160+#define OFFSET_HsIface_blockedOnBadFD_closure 152 #define REP_HsIface_blockedOnBadFD_closure b64 #define HsIface_blockedOnBadFD_closure(__ptr__) REP_HsIface_blockedOnBadFD_closure[__ptr__+OFFSET_HsIface_blockedOnBadFD_closure]-#define OFFSET_HsIface_runSparks_closure 168+#define OFFSET_HsIface_runSparks_closure 160 #define REP_HsIface_runSparks_closure b64 #define HsIface_runSparks_closure(__ptr__) REP_HsIface_runSparks_closure[__ptr__+OFFSET_HsIface_runSparks_closure]-#define OFFSET_HsIface_ensureIOManagerIsRunning_closure 176+#define OFFSET_HsIface_ensureIOManagerIsRunning_closure 168 #define REP_HsIface_ensureIOManagerIsRunning_closure b64 #define HsIface_ensureIOManagerIsRunning_closure(__ptr__) REP_HsIface_ensureIOManagerIsRunning_closure[__ptr__+OFFSET_HsIface_ensureIOManagerIsRunning_closure]-#define OFFSET_HsIface_interruptIOManager_closure 184+#define OFFSET_HsIface_interruptIOManager_closure 176 #define REP_HsIface_interruptIOManager_closure b64 #define HsIface_interruptIOManager_closure(__ptr__) REP_HsIface_interruptIOManager_closure[__ptr__+OFFSET_HsIface_interruptIOManager_closure]-#define OFFSET_HsIface_ioManagerCapabilitiesChanged_closure 192+#define OFFSET_HsIface_ioManagerCapabilitiesChanged_closure 184 #define REP_HsIface_ioManagerCapabilitiesChanged_closure b64 #define HsIface_ioManagerCapabilitiesChanged_closure(__ptr__) REP_HsIface_ioManagerCapabilitiesChanged_closure[__ptr__+OFFSET_HsIface_ioManagerCapabilitiesChanged_closure]-#define OFFSET_HsIface_runHandlersPtr_closure 200+#define OFFSET_HsIface_runHandlersPtr_closure 192 #define REP_HsIface_runHandlersPtr_closure b64 #define HsIface_runHandlersPtr_closure(__ptr__) REP_HsIface_runHandlersPtr_closure[__ptr__+OFFSET_HsIface_runHandlersPtr_closure]-#define OFFSET_HsIface_flushStdHandles_closure 208+#define OFFSET_HsIface_flushStdHandles_closure 200 #define REP_HsIface_flushStdHandles_closure b64 #define HsIface_flushStdHandles_closure(__ptr__) REP_HsIface_flushStdHandles_closure[__ptr__+OFFSET_HsIface_flushStdHandles_closure]-#define OFFSET_HsIface_runMainIO_closure 216+#define OFFSET_HsIface_runMainIO_closure 208 #define REP_HsIface_runMainIO_closure b64 #define HsIface_runMainIO_closure(__ptr__) REP_HsIface_runMainIO_closure[__ptr__+OFFSET_HsIface_runMainIO_closure]-#define OFFSET_HsIface_Czh_con_info 224+#define OFFSET_HsIface_Czh_con_info 216 #define REP_HsIface_Czh_con_info b64 #define HsIface_Czh_con_info(__ptr__) REP_HsIface_Czh_con_info[__ptr__+OFFSET_HsIface_Czh_con_info]-#define OFFSET_HsIface_Izh_con_info 232+#define OFFSET_HsIface_Izh_con_info 224 #define REP_HsIface_Izh_con_info b64 #define HsIface_Izh_con_info(__ptr__) REP_HsIface_Izh_con_info[__ptr__+OFFSET_HsIface_Izh_con_info]-#define OFFSET_HsIface_Fzh_con_info 240+#define OFFSET_HsIface_Fzh_con_info 232 #define REP_HsIface_Fzh_con_info b64 #define HsIface_Fzh_con_info(__ptr__) REP_HsIface_Fzh_con_info[__ptr__+OFFSET_HsIface_Fzh_con_info]-#define OFFSET_HsIface_Dzh_con_info 248+#define OFFSET_HsIface_Dzh_con_info 240 #define REP_HsIface_Dzh_con_info b64 #define HsIface_Dzh_con_info(__ptr__) REP_HsIface_Dzh_con_info[__ptr__+OFFSET_HsIface_Dzh_con_info]-#define OFFSET_HsIface_Wzh_con_info 256+#define OFFSET_HsIface_Wzh_con_info 248 #define REP_HsIface_Wzh_con_info b64 #define HsIface_Wzh_con_info(__ptr__) REP_HsIface_Wzh_con_info[__ptr__+OFFSET_HsIface_Wzh_con_info]+#define OFFSET_HsIface_runAllocationLimitHandler_closure 264+#define REP_HsIface_runAllocationLimitHandler_closure b64+#define HsIface_runAllocationLimitHandler_closure(__ptr__) REP_HsIface_runAllocationLimitHandler_closure[__ptr__+OFFSET_HsIface_runAllocationLimitHandler_closure] #define OFFSET_HsIface_Ptr_con_info 272 #define REP_HsIface_Ptr_con_info b64 #define HsIface_Ptr_con_info(__ptr__) REP_HsIface_Ptr_con_info[__ptr__+OFFSET_HsIface_Ptr_con_info]
ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -72,9 +72,6 @@ /* Define (to 1) if C compiler has an LLVM back end */ #define CC_LLVM_BACKEND 1 -/* Define to 1 if __thread is supported */-#define CC_SUPPORTS_TLS 1- /* Define to 1 if using 'alloca.c'. */ /* #undef C_ALLOCA */ @@ -85,9 +82,6 @@ /* Has musttail */ #define HAS_MUSTTAIL 1 -/* Has visibility hidden */-#define HAS_VISIBILITY_HIDDEN 1- /* Define to 1 if you have 'alloca', as a function or macro. */ #define HAVE_ALLOCA 1 @@ -171,6 +165,9 @@  /* Define to 1 if you have the 'getuid' function. */ #define HAVE_GETUID 1++/* Define (to 1) if GNU-style non-executable stack note is supported */+/* #undef HAVE_GNU_NONEXEC_STACK */  /* Define to 1 if you have the <grp.h> header file. */ #define HAVE_GRP_H 1
libraries/containers/containers/include/containers.h view
@@ -6,13 +6,13 @@ #define HASKELL_CONTAINERS_H  /*- * On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.+ * On GHC and MicroHs, include MachDeps.h to get WORD_SIZE_IN_BITS macro.  */-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) #include "MachDeps.h" #endif -#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) #define DEFINE_PATTERN_SYNONYMS 1 #endif 
rts/include/stg/MachRegs/loongarch64.h view
@@ -46,6 +46,3 @@ #define REG_D2          fs5 #define REG_D3          fs6 #define REG_D4          fs7--#define MAX_REAL_FLOAT_REG   4-#define MAX_REAL_DOUBLE_REG  4
rts/include/stg/MachRegs/ppc.h view
@@ -60,6 +60,3 @@ #define REG_SpLim       r25 #define REG_Hp          r26 #define REG_Base        r27--#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6
rts/include/stg/MachRegs/riscv64.h view
@@ -56,6 +56,3 @@ #define REG_D4          fs9 #define REG_D5          fs10 #define REG_D6          fs11--#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6